diff options
Diffstat (limited to 'gcc/ada/sem_util.adb')
| -rw-r--r-- | gcc/ada/sem_util.adb | 386 |
1 files changed, 41 insertions, 345 deletions
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index b0fcc17..51a6738 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -70,7 +70,7 @@ with GNAT.HTable; use GNAT.HTable; package body Sem_Util is ---------------------------------------- - -- Global_Variables for New_Copy_Tree -- + -- Global Variables for New_Copy_Tree -- ---------------------------------------- -- These global variables are used by New_Copy_Tree. See description of the @@ -110,12 +110,6 @@ package body Sem_Util is -- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints, -- Loc is the source location, T is the original subtype. - function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean; - -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type - -- with discriminants whose default values are static, examine only the - -- components in the selected variant to determine whether all of them - -- have a default. - function Has_Enabled_Property (Item_Id : Entity_Id; Property : Name_Id) return Boolean; @@ -127,6 +121,12 @@ package body Sem_Util is -- T is a derived tagged type. Check whether the type extension is null. -- If the parent type is fully initialized, T can be treated as such. + function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean; + -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type + -- with discriminants whose default values are static, examine only the + -- components in the selected variant to determine whether all of them + -- have a default. + ------------------------------ -- Abstract_Interface_List -- ------------------------------ @@ -2676,82 +2676,6 @@ package body Sem_Util is end if; end Check_Function_Writable_Actuals; - ---------------------------- - -- Check_Ghost_Completion -- - ---------------------------- - - procedure Check_Ghost_Completion - (Partial_View : Entity_Id; - Full_View : Entity_Id) - is - Policy : constant Name_Id := Policy_In_Effect (Name_Ghost); - - begin - -- The Ghost policy in effect at the point of declaration and at the - -- point of completion must match (SPARK RM 6.9(15)). - - if Is_Checked_Ghost_Entity (Partial_View) - and then Policy = Name_Ignore - then - Error_Msg_Sloc := Sloc (Full_View); - - Error_Msg_N ("incompatible ghost policies in effect", Partial_View); - Error_Msg_N ("\& declared with ghost policy Check", Partial_View); - Error_Msg_N ("\& completed # with ghost policy Ignore", Partial_View); - - elsif Is_Ignored_Ghost_Entity (Partial_View) - and then Policy = Name_Check - then - Error_Msg_Sloc := Sloc (Full_View); - - Error_Msg_N ("incompatible ghost policies in effect", Partial_View); - Error_Msg_N ("\& declared with ghost policy Ignore", Partial_View); - Error_Msg_N ("\& completed # with ghost policy Check", Partial_View); - end if; - end Check_Ghost_Completion; - - ---------------------------- - -- Check_Ghost_Derivation -- - ---------------------------- - - procedure Check_Ghost_Derivation (Typ : Entity_Id) is - Parent_Typ : constant Entity_Id := Etype (Typ); - Iface : Entity_Id; - Iface_Elmt : Elmt_Id; - - begin - -- Allow untagged derivations from predefined types such as Integer as - -- those are not Ghost by definition. - - if Is_Scalar_Type (Typ) and then Parent_Typ = Base_Type (Typ) then - null; - - -- The parent type of a Ghost type extension must be Ghost - - elsif not Is_Ghost_Entity (Parent_Typ) then - Error_Msg_N ("type extension & cannot be ghost", Typ); - Error_Msg_NE ("\parent type & is not ghost", Typ, Parent_Typ); - return; - end if; - - -- All progenitors (if any) must be Ghost as well - - if Is_Tagged_Type (Typ) and then Present (Interfaces (Typ)) then - Iface_Elmt := First_Elmt (Interfaces (Typ)); - while Present (Iface_Elmt) loop - Iface := Node (Iface_Elmt); - - if not Is_Ghost_Entity (Iface) then - Error_Msg_N ("type extension & cannot be ghost", Typ); - Error_Msg_NE ("\interface type & is not ghost", Typ, Iface); - return; - end if; - - Next_Elmt (Iface_Elmt); - end loop; - end if; - end Check_Ghost_Derivation; - -------------------------------- -- Check_Implicit_Dereference -- -------------------------------- @@ -9498,7 +9422,7 @@ package body Sem_Util is Pkg_Decl : Node_Id := Pkg; begin - if Ekind (Pkg) = E_Package then + if Present (Pkg) and then Ekind (Pkg) = E_Package then while Nkind (Pkg_Decl) /= N_Package_Specification loop Pkg_Decl := Parent (Pkg_Decl); end loop; @@ -10437,6 +10361,39 @@ package body Sem_Util is and then Is_Imported (Entity (Name (N))); end Is_CPP_Constructor_Call; + -------------------- + -- Is_Declaration -- + -------------------- + + function Is_Declaration (N : Node_Id) return Boolean is + begin + case Nkind (N) is + when N_Abstract_Subprogram_Declaration | + N_Exception_Declaration | + N_Exception_Renaming_Declaration | + N_Full_Type_Declaration | + N_Generic_Function_Renaming_Declaration | + N_Generic_Package_Declaration | + N_Generic_Package_Renaming_Declaration | + N_Generic_Procedure_Renaming_Declaration | + N_Generic_Subprogram_Declaration | + N_Number_Declaration | + N_Object_Declaration | + N_Object_Renaming_Declaration | + N_Package_Declaration | + N_Package_Renaming_Declaration | + N_Private_Extension_Declaration | + N_Private_Type_Declaration | + N_Subprogram_Declaration | + N_Subprogram_Renaming_Declaration | + N_Subtype_Declaration => + return True; + + when others => + return False; + end case; + end Is_Declaration; + ----------------- -- Is_Delegate -- ----------------- @@ -11209,110 +11166,6 @@ package body Sem_Util is end if; end Is_Fully_Initialized_Variant; - --------------------- - -- Is_Ghost_Entity -- - --------------------- - - function Is_Ghost_Entity (Id : Entity_Id) return Boolean is - begin - return Is_Checked_Ghost_Entity (Id) or else Is_Ignored_Ghost_Entity (Id); - end Is_Ghost_Entity; - - ---------------------------------- - -- Is_Ghost_Statement_Or_Pragma -- - ---------------------------------- - - function Is_Ghost_Statement_Or_Pragma (N : Node_Id) return Boolean is - function Is_Ghost_Entity_Reference (N : Node_Id) return Boolean; - -- Determine whether an arbitrary node denotes a reference to a Ghost - -- entity. - - ------------------------------- - -- Is_Ghost_Entity_Reference -- - ------------------------------- - - function Is_Ghost_Entity_Reference (N : Node_Id) return Boolean is - Ref : Node_Id; - - begin - Ref := N; - - -- When the reference extracts a subcomponent, recover the related - -- object (SPARK RM 6.9(1)). - - while Nkind_In (Ref, N_Explicit_Dereference, - N_Indexed_Component, - N_Selected_Component, - N_Slice) - loop - Ref := Prefix (Ref); - end loop; - - return - Is_Entity_Name (Ref) - and then Present (Entity (Ref)) - and then Is_Ghost_Entity (Entity (Ref)); - end Is_Ghost_Entity_Reference; - - -- Local variables - - Arg : Node_Id; - Stmt : Node_Id; - - -- Start of processing for Is_Ghost_Statement_Or_Pragma - - begin - if Nkind (N) = N_Pragma then - - -- A pragma is Ghost when it appears within a Ghost package or - -- subprogram. - - if Within_Ghost_Scope then - return True; - end if; - - -- A pragma is Ghost when it mentions a Ghost entity - - Arg := First (Pragma_Argument_Associations (N)); - while Present (Arg) loop - if Is_Ghost_Entity_Reference (Get_Pragma_Arg (Arg)) then - return True; - end if; - - Next (Arg); - end loop; - end if; - - Stmt := N; - while Present (Stmt) loop - - -- A statement is Ghost when it appears within a Ghost package or - -- subprogram. - - if Is_Statement (Stmt) and then Within_Ghost_Scope then - return True; - - -- An assignment statement is Ghost when the target is a Ghost - -- variable. A procedure call is Ghost when the invoked procedure - -- is Ghost. - - elsif Nkind_In (Stmt, N_Assignment_Statement, - N_Procedure_Call_Statement) - then - return Is_Ghost_Entity_Reference (Name (Stmt)); - - -- Prevent the search from going too far - - elsif Is_Body_Or_Package_Declaration (Stmt) then - return False; - end if; - - Stmt := Parent (Stmt); - end loop; - - return False; - end Is_Ghost_Statement_Or_Pragma; - ---------------------------- -- Is_Inherited_Operation -- ---------------------------- @@ -12417,123 +12270,6 @@ package body Sem_Util is or else Nkind (N) = N_Procedure_Call_Statement; end Is_Statement; - ------------------------- - -- Is_Subject_To_Ghost -- - ------------------------- - - function Is_Subject_To_Ghost (N : Node_Id) return Boolean is - function Enables_Ghostness (Arg : Node_Id) return Boolean; - -- Determine whether aspect or pragma argument Arg enables "ghostness" - - ----------------------- - -- Enables_Ghostness -- - ----------------------- - - function Enables_Ghostness (Arg : Node_Id) return Boolean is - Expr : Node_Id; - - begin - Expr := Arg; - - if Nkind (Expr) = N_Pragma_Argument_Association then - Expr := Get_Pragma_Arg (Expr); - end if; - - -- Determine whether the expression of the aspect is static and - -- denotes True. - - if Present (Expr) then - Preanalyze_And_Resolve (Expr); - - return - Is_OK_Static_Expression (Expr) - and then Is_True (Expr_Value (Expr)); - - -- Otherwise Ghost defaults to True - - else - return True; - end if; - end Enables_Ghostness; - - -- Local variables - - Id : constant Entity_Id := Defining_Entity (N); - Asp : Node_Id; - Decl : Node_Id; - Prev_Id : Entity_Id; - - -- Start of processing for Is_Subject_To_Ghost - - begin - if Is_Ghost_Entity (Id) then - return True; - - -- The completion of a type or a constant is not fully analyzed when the - -- reference to the Ghost entity is resolved. Because the completion is - -- not marked as Ghost yet, inspect the partial view. - - elsif Is_Record_Type (Id) - or else Ekind (Id) = E_Constant - or else (Nkind (N) = N_Object_Declaration - and then Constant_Present (N)) - then - Prev_Id := Incomplete_Or_Partial_View (Id); - - if Present (Prev_Id) and then Is_Ghost_Entity (Prev_Id) then - return True; - end if; - end if; - - -- Examine the aspect specifications (if any) looking for aspect Ghost - - if Permits_Aspect_Specifications (N) then - Asp := First (Aspect_Specifications (N)); - while Present (Asp) loop - if Chars (Identifier (Asp)) = Name_Ghost then - return Enables_Ghostness (Expression (Asp)); - end if; - - Next (Asp); - end loop; - end if; - - Decl := Empty; - - -- When the context is a [generic] package declaration, pragma Ghost - -- resides in the visible declarations. - - if Nkind_In (N, N_Generic_Package_Declaration, - N_Package_Declaration) - then - Decl := First (Visible_Declarations (Specification (N))); - - -- Otherwise pragma Ghost appears in the declarations following N - - elsif Is_List_Member (N) then - Decl := Next (N); - end if; - - while Present (Decl) loop - if Nkind (Decl) = N_Pragma - and then Pragma_Name (Decl) = Name_Ghost - then - return - Enables_Ghostness (First (Pragma_Argument_Associations (Decl))); - - -- A source construct ends the region where pragma Ghost may appear, - -- stop the traversal. - - elsif Comes_From_Source (Decl) then - exit; - end if; - - Next (Decl); - end loop; - - return False; - end Is_Subject_To_Ghost; - -------------------------------------------------- -- Is_Subprogram_Stub_Without_Prior_Declaration -- -------------------------------------------------- @@ -17265,22 +17001,6 @@ package body Sem_Util is Set_Entity (N, Val); end Set_Entity_With_Checks; - ------------------------- - -- Set_Is_Ghost_Entity -- - ------------------------- - - procedure Set_Is_Ghost_Entity (Id : Entity_Id) is - Policy : constant Name_Id := Policy_In_Effect (Name_Ghost); - - begin - if Policy = Name_Check then - Set_Is_Checked_Ghost_Entity (Id); - - elsif Policy = Name_Ignore then - Set_Is_Ignored_Ghost_Entity (Id); - end if; - end Set_Is_Ghost_Entity; - ------------------------ -- Set_Name_Entity_Id -- ------------------------ @@ -18213,30 +17933,6 @@ package body Sem_Util is return List_1; end Visible_Ancestors; - ------------------------ - -- Within_Ghost_Scope -- - ------------------------ - - function Within_Ghost_Scope - (Id : Entity_Id := Current_Scope) return Boolean - is - S : Entity_Id; - - begin - -- Climb the scope stack looking for a Ghost scope - - S := Id; - while Present (S) and then S /= Standard_Standard loop - if Is_Ghost_Entity (S) then - return True; - end if; - - S := Scope (S); - end loop; - - return False; - end Within_Ghost_Scope; - ---------------------- -- Within_Init_Proc -- ---------------------- |