diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 513f3afe219..a8f16d80584 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,71 @@ +2015-10-23 Bob Duff + + * exp_strm.adb (Build_Record_Or_Elementary_Input_Function): Use + Underlying_Type for B_Typ, in case the Typ is a subtype of a type with + unknown discriminants. + * g-awk.ads: Minor style fix in comment + +2015-10-23 Hristian Kirtchev + + * debug.adb: Document the use of debug switch -gnatd.5. + * einfo.adb: Code reformatting. (Is_Ghost_Entity): Moved from ghost.adb. + * einfo.ads New synthesized attribute Is_Ghost_Enity along + with usage in nodes and pragma Inline. + (Is_Ghost_Entity: Moved from ghost.ads. + * exp_ch3.adb Code reformatting. + (Expand_Freeze_Array_Type): Capture, set and restore the Ghost mode. + (Expand_Freeze_Class_Wide_Type): Capture, set and restore the + Ghost mode. + (Expand_Freeze_Enumeration_Type): Capture, set and + restore the Ghost mode. + (Expand_Freeze_Record_Type): Capture, set and restore the Ghost mode. + * exp_ch6.adb (Expand_Subprogram_Contract): Do not expand the + contract of an ignored Ghost subprogram. + * exp_ch13.adb Add with and use clauses for Ghost. + (Expand_N_Freeze_Entity): Capture, set and restore the Ghost mode. + * exp_dbug.adb (Get_External_Name): Code reformatting. Add a + special prefix for ignored Ghost entities or when requested by + -gnatd.5 for any Ghost entity. + * exp_dbug.ads Document the use of prefix "_ghost_" for ignored + Ghost entities. + * exp_prag.adb (Expand_Pragma_Check): Capture, set and restore the + Ghost mode. + (Expand_Pragma_Loop_Variant): Use In_Assertion_Expr + to signal the original context. + * ghost.adb (Check_Ghost_Overriding): Code cleanup. + (Is_Ghost_Entity): Moved to einfo.adb. (Is_OK_Declaration): + Move the assertion expression check to the outer level. + (Is_OK_Ghost_Context): An assertion expression is a valid Ghost + context. + * ghost.ads (Is_Ghost_Entity): Moved to einfo.ads. + * sem_ch3.adb (Analyze_Object_Contract): A source Ghost object + cannot be imported or exported. Mark internally generated objects + as Ghost when applicable. + (Make_Class_Wide_Type): Inherit the ghostness of the root tagged type. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Mark + a stand alone subprogram body as Ghost when applicable. + (Analyze_Subprogram_Declaration): Mark internally generated + subprograms as Ghost when applicable. + * sem_ch7.adb: Code cleanup. + * sem_ch13.adb (Add_Invariants): Add various formal + parameters to break dependency on global variables. + (Build_Invariant_Procedure): Code cleanup. Capture, set and + restore the Ghost mode. + * sem_res.adb (Resolve_Actuals): The actual parameter of a source + Ghost subprogram whose formal is of mode IN OUT or OUT must be + a Ghost variable. + +2015-10-23 Hristian Kirtchev + + * sem_ch8.adb Code cleanup. + (Find_Expanded_Name): Replace + the call to In_Pragmas_Depends_Or_Global with a call to + In_Abstract_View_Pragma. + (In_Abstract_View_Pragma): New routine. + (In_Pragmas_Depends_Or_Global): Removed. + * sem_prag.adb (Analyze_Part_Of): Catch a case where indicator + Part_Of denotes the abstract view of a variable. + 2015-10-23 Arnaud Charlet * sem_util.ads (Unique_Defining_Entity): Document the result diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 29872b630a0..68cca0c43c1 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -159,7 +159,7 @@ package body Debug is -- d.2 Allow statements in declarative part -- d.3 Output debugging information from Exp_Unst -- d.4 - -- d.5 + -- d.5 Generate Ghost external sumbols regardless of Ghost policy -- d.6 -- d.7 -- d.8 @@ -762,6 +762,12 @@ package body Debug is -- d.3 Output debugging information from Exp_Unst, including the name of -- any unreachable subprograms that get deleted. + -- d.5 Generate specialized external symbols for Ghost entities where the + -- name of the entity is prefixed by "_ghost_" regardless of whether + -- the Ghost policy is Check or Ignore. WARNING: This switch may cause + -- linking issues related to Ghost entities declared with Ghost policy + -- Check. + ------------------------------------------ -- Documentation for Binder Debug Flags -- ------------------------------------------ diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index dff2a2b7843..1572a9a794e 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -3399,8 +3399,7 @@ package body Einfo is function Is_Concurrent_Body (Id : E) return B is begin - return Ekind (Id) in - Concurrent_Body_Kind; + return Ekind (Id) in Concurrent_Body_Kind; end Is_Concurrent_Body; function Is_Concurrent_Record_Type (Id : E) return B is @@ -3415,8 +3414,7 @@ package body Einfo is function Is_Decimal_Fixed_Point_Type (Id : E) return B is begin - return Ekind (Id) in - Decimal_Fixed_Point_Kind; + return Ekind (Id) in Decimal_Fixed_Point_Kind; end Is_Decimal_Fixed_Point_Type; function Is_Digits_Type (Id : E) return B is @@ -3446,14 +3444,12 @@ package body Einfo is function Is_Enumeration_Type (Id : E) return B is begin - return Ekind (Id) in - Enumeration_Kind; + return Ekind (Id) in Enumeration_Kind; end Is_Enumeration_Type; function Is_Fixed_Point_Type (Id : E) return B is begin - return Ekind (Id) in - Fixed_Point_Kind; + return Ekind (Id) in Fixed_Point_Kind; end Is_Fixed_Point_Type; function Is_Floating_Point_Type (Id : E) return B is @@ -3481,16 +3477,19 @@ package body Einfo is return Ekind (Id) in Generic_Unit_Kind; end Is_Generic_Unit; + 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; + function Is_Incomplete_Or_Private_Type (Id : E) return B is begin - return Ekind (Id) in - Incomplete_Or_Private_Kind; + return Ekind (Id) in Incomplete_Or_Private_Kind; end Is_Incomplete_Or_Private_Type; function Is_Incomplete_Type (Id : E) return B is begin - return Ekind (Id) in - Incomplete_Kind; + return Ekind (Id) in Incomplete_Kind; end Is_Incomplete_Type; function Is_Integer_Type (Id : E) return B is @@ -3500,8 +3499,7 @@ package body Einfo is function Is_Modular_Integer_Type (Id : E) return B is begin - return Ekind (Id) in - Modular_Integer_Kind; + return Ekind (Id) in Modular_Integer_Kind; end Is_Modular_Integer_Type; function Is_Named_Number (Id : E) return B is @@ -3521,8 +3519,7 @@ package body Einfo is function Is_Ordinary_Fixed_Point_Type (Id : E) return B is begin - return Ekind (Id) in - Ordinary_Fixed_Point_Kind; + return Ekind (Id) in Ordinary_Fixed_Point_Kind; end Is_Ordinary_Fixed_Point_Type; function Is_Overloadable (Id : E) return B is diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index bea9dacf502..1426c4fccb8 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2502,6 +2502,13 @@ package Einfo is -- package, generic function, generic procedure), and False for all -- other entities. +-- Is_Ghost_Entity (synthesized) +-- Applies to all entities. Yields True for abstract states, [generic] +-- packages, [generic] subprograms, components, discriminants, formal +-- parameters, objects, package bodies, subprogram bodies, and [sub]types +-- subject to pragma Ghost or those that inherit the Ghost propery from +-- an enclosing construct. + -- Is_Hidden (Flag57) -- Defined in all entities. Set for all entities declared in the -- private part or body of a package. Also marks generic formals of a @@ -5384,6 +5391,7 @@ package Einfo is -- Declaration_Node (synth) -- Has_Foreign_Convention (synth) -- Is_Dynamic_Scope (synth) + -- Is_Ghost_Entity (synth) -- Is_Standard_Character_Type (synth) -- Is_Standard_String_Type (synth) -- Underlying_Type (synth) @@ -7158,9 +7166,10 @@ package Einfo is function Is_Formal_Subprogram (Id : E) return B; function Is_Generic_Actual_Subprogram (Id : E) return B; function Is_Generic_Actual_Type (Id : E) return B; - function Is_Generic_Unit (Id : E) return B; - function Is_Generic_Type (Id : E) return B; function Is_Generic_Subprogram (Id : E) return B; + function Is_Generic_Type (Id : E) return B; + function Is_Generic_Unit (Id : E) return B; + function Is_Ghost_Entity (Id : E) return B; function Is_Incomplete_Or_Private_Type (Id : E) return B; function Is_Incomplete_Type (Id : E) return B; function Is_Integer_Type (Id : E) return B; @@ -8380,6 +8389,7 @@ package Einfo is pragma Inline (Is_Generic_Subprogram); pragma Inline (Is_Generic_Type); pragma Inline (Is_Generic_Unit); + pragma Inline (Is_Ghost_Entity); pragma Inline (Is_Hidden); pragma Inline (Is_Hidden_Non_Overridden_Subpgm); pragma Inline (Is_Hidden_Open_Scope); diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 6fd7dedfcae..11e75f37b8b 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -32,6 +32,7 @@ with Exp_Imgv; use Exp_Imgv; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Freeze; use Freeze; +with Ghost; use Ghost; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; @@ -361,14 +362,21 @@ package body Exp_Ch13 is ---------------------------- procedure Expand_N_Freeze_Entity (N : Node_Id) is - E : constant Entity_Id := Entity (N); + E : constant Entity_Id := Entity (N); + + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + + Decl : Node_Id; + Delete : Boolean := False; E_Scope : Entity_Id; In_Other_Scope : Boolean; In_Outer_Scope : Boolean; - Decl : Node_Id; - Delete : Boolean := False; begin + -- Ensure that all freezing activities are properly flagged as Ghost + + Set_Ghost_Mode_From_Entity (E); + -- If there are delayed aspect specifications, we insert them just -- before the freeze node. They are already analyzed so we don't need -- to reanalyze them (they were analyzed before the type was frozen), @@ -436,13 +444,14 @@ package body Exp_Ch13 is -- statement, insert them back into the tree now. Explode_Initialization_Compound_Statement (E); - + Ghost_Mode := Save_Ghost_Mode; return; -- Only other items requiring any front end action are types and -- subprograms. elsif not Is_Type (E) and then not Is_Subprogram (E) then + Ghost_Mode := Save_Ghost_Mode; return; end if; @@ -454,6 +463,7 @@ package body Exp_Ch13 is if No (E_Scope) then Check_Error_Detected; + Ghost_Mode := Save_Ghost_Mode; return; end if; @@ -671,6 +681,7 @@ package body Exp_Ch13 is -- whether we are inside a (possibly nested) call to this procedure. Inside_Freezing_Actions := Inside_Freezing_Actions - 1; + Ghost_Mode := Save_Ghost_Mode; end Expand_N_Freeze_Entity; ------------------------------------------- diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index edbca032d53..57104b3d33c 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -4573,130 +4573,1137 @@ package body Exp_Ch3 is end if; end Check_Stream_Attributes; - ----------------------------- - -- Expand_Record_Extension -- - ----------------------------- + ---------------------- + -- Clean_Task_Names -- + ---------------------- - -- Add a field _parent at the beginning of the record extension. This is - -- used to implement inheritance. Here are some examples of expansion: + procedure Clean_Task_Names + (Typ : Entity_Id; + Proc_Id : Entity_Id) + is + begin + if Has_Task (Typ) + and then not Restriction_Active (No_Implicit_Heap_Allocations) + and then not Global_Discard_Names + and then Tagged_Type_Expansion + then + Set_Uses_Sec_Stack (Proc_Id); + end if; + end Clean_Task_Names; - -- 1. no discriminants - -- type T2 is new T1 with null record; - -- gives - -- type T2 is new T1 with record - -- _Parent : T1; - -- end record; + ------------------------------ + -- Expand_Freeze_Array_Type -- + ------------------------------ - -- 2. renamed discriminants - -- type T2 (B, C : Int) is new T1 (A => B) with record - -- _Parent : T1 (A => B); - -- D : Int; - -- end; + procedure Expand_Freeze_Array_Type (N : Node_Id) is + Typ : constant Entity_Id := Entity (N); + Base : constant Entity_Id := Base_Type (Typ); + Comp_Typ : constant Entity_Id := Component_Type (Typ); - -- 3. inherited discriminants - -- type T2 is new T1 with record -- discriminant A inherited - -- _Parent : T1 (A); - -- D : Int; - -- end; + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; - procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is - Indic : constant Node_Id := Subtype_Indication (Def); - Loc : constant Source_Ptr := Sloc (Def); - Rec_Ext_Part : Node_Id := Record_Extension_Part (Def); - Par_Subtype : Entity_Id; - Comp_List : Node_Id; - Comp_Decl : Node_Id; - Parent_N : Node_Id; - D : Entity_Id; - List_Constr : constant List_Id := New_List; + Ins_Node : Node_Id; begin - -- Expand_Record_Extension is called directly from the semantics, so - -- we must check to see whether expansion is active before proceeding, - -- because this affects the visibility of selected components in bodies - -- of instances. + -- Ensure that all freezing activities are properly flagged as Ghost - if not Expander_Active then + Set_Ghost_Mode_From_Entity (Typ); + + if not Is_Bit_Packed_Array (Typ) then + + -- If the component contains tasks, so does the array type. This may + -- not be indicated in the array type because the component may have + -- been a private type at the point of definition. Same if component + -- type is controlled or contains protected objects. + + Set_Has_Task (Base, Has_Task (Comp_Typ)); + Set_Has_Protected (Base, Has_Protected (Comp_Typ)); + Set_Has_Controlled_Component + (Base, Has_Controlled_Component + (Comp_Typ) + or else + Is_Controlled (Comp_Typ)); + + if No (Init_Proc (Base)) then + + -- If this is an anonymous array created for a declaration with + -- an initial value, its init_proc will never be called. The + -- initial value itself may have been expanded into assignments, + -- in which case the object declaration is carries the + -- No_Initialization flag. + + if Is_Itype (Base) + and then Nkind (Associated_Node_For_Itype (Base)) = + N_Object_Declaration + and then + (Present (Expression (Associated_Node_For_Itype (Base))) + or else No_Initialization (Associated_Node_For_Itype (Base))) + then + null; + + -- We do not need an init proc for string or wide [wide] string, + -- since the only time these need initialization in normalize or + -- initialize scalars mode, and these types are treated specially + -- and do not need initialization procedures. + + elsif Is_Standard_String_Type (Base) then + null; + + -- Otherwise we have to build an init proc for the subtype + + else + Build_Array_Init_Proc (Base, N); + end if; + end if; + + if Typ = Base then + if Has_Controlled_Component (Base) then + Build_Controlling_Procs (Base); + + if not Is_Limited_Type (Comp_Typ) + and then Number_Dimensions (Typ) = 1 + then + Build_Slice_Assignment (Typ); + end if; + end if; + + -- Create a finalization master to service the anonymous access + -- components of the array. + + if Ekind (Comp_Typ) = E_Anonymous_Access_Type + and then Needs_Finalization (Designated_Type (Comp_Typ)) + then + -- The finalization master is inserted before the declaration + -- of the array type. The only exception to this is when the + -- array type is an itype, in which case the master appears + -- before the related context. + + if Is_Itype (Typ) then + Ins_Node := Associated_Node_For_Itype (Typ); + else + Ins_Node := Parent (Typ); + end if; + + Build_Finalization_Master + (Typ => Comp_Typ, + For_Anonymous => True, + Context_Scope => Scope (Typ), + Insertion_Node => Ins_Node); + end if; + end if; + + -- For packed case, default initialization, except if the component type + -- is itself a packed structure with an initialization procedure, or + -- initialize/normalize scalars active, and we have a base type, or the + -- type is public, because in that case a client might specify + -- Normalize_Scalars and there better be a public Init_Proc for it. + + elsif (Present (Init_Proc (Component_Type (Base))) + and then No (Base_Init_Proc (Base))) + or else (Init_Or_Norm_Scalars and then Base = Typ) + or else Is_Public (Typ) + then + Build_Array_Init_Proc (Base, N); + end if; + + if Has_Invariants (Component_Type (Base)) + and then Typ = Base + and then In_Open_Scopes (Scope (Component_Type (Base))) + then + -- Generate component invariant checking procedure. This is only + -- relevant if the array type is within the scope of the component + -- type. Otherwise an array object can only be built using the public + -- subprograms for the component type, and calls to those will have + -- invariant checks. The invariant procedure is only generated for + -- a base type, not a subtype. + + Insert_Component_Invariant_Checks + (N, Base, Build_Array_Invariant_Proc (Base, N)); + end if; + + Ghost_Mode := Save_Ghost_Mode; + end Expand_Freeze_Array_Type; + + ----------------------------------- + -- Expand_Freeze_Class_Wide_Type -- + ----------------------------------- + + procedure Expand_Freeze_Class_Wide_Type (N : Node_Id) is + function Is_C_Derivation (Typ : Entity_Id) return Boolean; + -- Given a type, determine whether it is derived from a C or C++ root + + --------------------- + -- Is_C_Derivation -- + --------------------- + + function Is_C_Derivation (Typ : Entity_Id) return Boolean is + T : Entity_Id; + + begin + T := Typ; + loop + if Is_CPP_Class (T) + or else Convention (T) = Convention_C + or else Convention (T) = Convention_CPP + then + return True; + end if; + + exit when T = Etype (T); + + T := Etype (T); + end loop; + + return False; + end Is_C_Derivation; + + -- Local variables + + Typ : constant Entity_Id := Entity (N); + Root : constant Entity_Id := Root_Type (Typ); + + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + + -- Start of processing for Expand_Freeze_Class_Wide_Type + + begin + -- Certain run-time configurations and targets do not provide support + -- for controlled types. + + if Restriction_Active (No_Finalization) then + return; + + -- Do not create TSS routine Finalize_Address when dispatching calls are + -- disabled since the core of the routine is a dispatching call. + + elsif Restriction_Active (No_Dispatching_Calls) then + return; + + -- Do not create TSS routine Finalize_Address for concurrent class-wide + -- types. Ignore C, C++, CIL and Java types since it is assumed that the + -- non-Ada side will handle their destruction. + + elsif Is_Concurrent_Type (Root) + or else Is_C_Derivation (Root) + or else Convention (Typ) = Convention_CPP + then + return; + + -- Do not create TSS routine Finalize_Address when compiling in CodePeer + -- mode since the routine contains an Unchecked_Conversion. + + elsif CodePeer_Mode then return; end if; - -- This may be a derivation of an untagged private type whose full - -- view is tagged, in which case the Derived_Type_Definition has no - -- extension part. Build an empty one now. + -- Ensure that all freezing activities are properly flagged as Ghost - if No (Rec_Ext_Part) then - Rec_Ext_Part := - Make_Record_Definition (Loc, - End_Label => Empty, - Component_List => Empty, - Null_Present => True); + Set_Ghost_Mode_From_Entity (Typ); - Set_Record_Extension_Part (Def, Rec_Ext_Part); - Mark_Rewrite_Insertion (Rec_Ext_Part); - end if; + -- Create the body of TSS primitive Finalize_Address. This automatically + -- sets the TSS entry for the class-wide type. - Comp_List := Component_List (Rec_Ext_Part); + Make_Finalize_Address_Body (Typ); + Ghost_Mode := Save_Ghost_Mode; + end Expand_Freeze_Class_Wide_Type; - Parent_N := Make_Defining_Identifier (Loc, Name_uParent); + ------------------------------------ + -- Expand_Freeze_Enumeration_Type -- + ------------------------------------ - -- If the derived type inherits its discriminants the type of the - -- _parent field must be constrained by the inherited discriminants + procedure Expand_Freeze_Enumeration_Type (N : Node_Id) is + Typ : constant Entity_Id := Entity (N); + Loc : constant Source_Ptr := Sloc (Typ); - if Has_Discriminants (T) - and then Nkind (Indic) /= N_Subtype_Indication - and then not Is_Constrained (Entity (Indic)) - then - D := First_Discriminant (T); - while Present (D) loop - Append_To (List_Constr, New_Occurrence_Of (D, Loc)); - Next_Discriminant (D); + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + + Arr : Entity_Id; + Ent : Entity_Id; + Fent : Entity_Id; + Is_Contiguous : Boolean; + Ityp : Entity_Id; + Last_Repval : Uint; + Lst : List_Id; + Num : Nat; + Pos_Expr : Node_Id; + + Func : Entity_Id; + pragma Warnings (Off, Func); + + begin + -- Ensure that all freezing activities are properly flagged as Ghost + + Set_Ghost_Mode_From_Entity (Typ); + + -- Various optimizations possible if given representation is contiguous + + Is_Contiguous := True; + + Ent := First_Literal (Typ); + Last_Repval := Enumeration_Rep (Ent); + + Next_Literal (Ent); + while Present (Ent) loop + if Enumeration_Rep (Ent) - Last_Repval /= 1 then + Is_Contiguous := False; + exit; + else + Last_Repval := Enumeration_Rep (Ent); + end if; + + Next_Literal (Ent); + end loop; + + if Is_Contiguous then + Set_Has_Contiguous_Rep (Typ); + Ent := First_Literal (Typ); + Num := 1; + Lst := New_List (New_Occurrence_Of (Ent, Sloc (Ent))); + + else + -- Build list of literal references + + Lst := New_List; + Num := 0; + + Ent := First_Literal (Typ); + while Present (Ent) loop + Append_To (Lst, New_Occurrence_Of (Ent, Sloc (Ent))); + Num := Num + 1; + Next_Literal (Ent); end loop; - - Par_Subtype := - Process_Subtype ( - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Occurrence_Of (Entity (Indic), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => List_Constr)), - Def); - - -- Otherwise the original subtype_indication is just what is needed - - else - Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def); end if; - Set_Parent_Subtype (T, Par_Subtype); + -- Now build an array declaration - Comp_Decl := - Make_Component_Declaration (Loc, - Defining_Identifier => Parent_N, - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => New_Occurrence_Of (Par_Subtype, Loc))); + -- typA : array (Natural range 0 .. num - 1) of ctype := + -- (v, v, v, v, v, ....) - if Null_Present (Rec_Ext_Part) then - Set_Component_List (Rec_Ext_Part, - Make_Component_List (Loc, - Component_Items => New_List (Comp_Decl), - Variant_Part => Empty, - Null_Present => False)); - Set_Null_Present (Rec_Ext_Part, False); + -- where ctype is the corresponding integer type. If the representation + -- is contiguous, we only keep the first literal, which provides the + -- offset for Pos_To_Rep computations. - elsif Null_Present (Comp_List) - or else Is_Empty_List (Component_Items (Comp_List)) + Arr := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), 'A')); + + Append_Freeze_Action (Typ, + Make_Object_Declaration (Loc, + Defining_Identifier => Arr, + Constant_Present => True, + + Object_Definition => + Make_Constrained_Array_Definition (Loc, + Discrete_Subtype_Definitions => New_List ( + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc), + Constraint => + Make_Range_Constraint (Loc, + Range_Expression => + Make_Range (Loc, + Low_Bound => + Make_Integer_Literal (Loc, 0), + High_Bound => + Make_Integer_Literal (Loc, Num - 1))))), + + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => New_Occurrence_Of (Typ, Loc))), + + Expression => + Make_Aggregate (Loc, + Expressions => Lst))); + + Set_Enum_Pos_To_Rep (Typ, Arr); + + -- Now we build the function that converts representation values to + -- position values. This function has the form: + + -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is + -- begin + -- case ityp!(A) is + -- when enum-lit'Enum_Rep => return posval; + -- when enum-lit'Enum_Rep => return posval; + -- ... + -- when others => + -- [raise Constraint_Error when F "invalid data"] + -- return -1; + -- end case; + -- end; + + -- Note: the F parameter determines whether the others case (no valid + -- representation) raises Constraint_Error or returns a unique value + -- of minus one. The latter case is used, e.g. in 'Valid code. + + -- Note: the reason we use Enum_Rep values in the case here is to avoid + -- the code generator making inappropriate assumptions about the range + -- of the values in the case where the value is invalid. ityp is a + -- signed or unsigned integer type of appropriate width. + + -- Note: if exceptions are not supported, then we suppress the raise + -- and return -1 unconditionally (this is an erroneous program in any + -- case and there is no obligation to raise Constraint_Error here). We + -- also do this if pragma Restrictions (No_Exceptions) is active. + + -- Is this right??? What about No_Exception_Propagation??? + + -- Representations are signed + + if Enumeration_Rep (First_Literal (Typ)) < 0 then + + -- The underlying type is signed. Reset the Is_Unsigned_Type + -- explicitly, because it might have been inherited from + -- parent type. + + Set_Is_Unsigned_Type (Typ, False); + + if Esize (Typ) <= Standard_Integer_Size then + Ityp := Standard_Integer; + else + Ityp := Universal_Integer; + end if; + + -- Representations are unsigned + + else + if Esize (Typ) <= Standard_Integer_Size then + Ityp := RTE (RE_Unsigned); + else + Ityp := RTE (RE_Long_Long_Unsigned); + end if; + end if; + + -- The body of the function is a case statement. First collect case + -- alternatives, or optimize the contiguous case. + + Lst := New_List; + + -- If representation is contiguous, Pos is computed by subtracting + -- the representation of the first literal. + + if Is_Contiguous then + Ent := First_Literal (Typ); + + if Enumeration_Rep (Ent) = Last_Repval then + + -- Another special case: for a single literal, Pos is zero + + Pos_Expr := Make_Integer_Literal (Loc, Uint_0); + + else + Pos_Expr := + Convert_To (Standard_Integer, + Make_Op_Subtract (Loc, + Left_Opnd => + Unchecked_Convert_To + (Ityp, Make_Identifier (Loc, Name_uA)), + Right_Opnd => + Make_Integer_Literal (Loc, + Intval => Enumeration_Rep (First_Literal (Typ))))); + end if; + + Append_To (Lst, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List ( + Make_Range (Sloc (Enumeration_Rep_Expr (Ent)), + Low_Bound => + Make_Integer_Literal (Loc, + Intval => Enumeration_Rep (Ent)), + High_Bound => + Make_Integer_Literal (Loc, Intval => Last_Repval))), + + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => Pos_Expr)))); + + else + Ent := First_Literal (Typ); + while Present (Ent) loop + Append_To (Lst, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List ( + Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)), + Intval => Enumeration_Rep (Ent))), + + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Make_Integer_Literal (Loc, + Intval => Enumeration_Pos (Ent)))))); + + Next_Literal (Ent); + end loop; + end if; + + -- In normal mode, add the others clause with the test + + if not No_Exception_Handlers_Set then + Append_To (Lst, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List ( + Make_Raise_Constraint_Error (Loc, + Condition => Make_Identifier (Loc, Name_uF), + Reason => CE_Invalid_Data), + Make_Simple_Return_Statement (Loc, + Expression => + Make_Integer_Literal (Loc, -1))))); + + -- If either of the restrictions No_Exceptions_Handlers/Propagation is + -- active then return -1 (we cannot usefully raise Constraint_Error in + -- this case). See description above for further details. + + else + Append_To (Lst, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Make_Integer_Literal (Loc, -1))))); + end if; + + -- Now we can build the function body + + Fent := + Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos)); + + Func := + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Fent, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uA), + Parameter_Type => New_Occurrence_Of (Typ, Loc)), + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_uF), + Parameter_Type => + New_Occurrence_Of (Standard_Boolean, Loc))), + + Result_Definition => New_Occurrence_Of (Standard_Integer, Loc)), + + Declarations => Empty_List, + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Case_Statement (Loc, + Expression => + Unchecked_Convert_To + (Ityp, Make_Identifier (Loc, Name_uA)), + Alternatives => Lst)))); + + Set_TSS (Typ, Fent); + + -- Set Pure flag (it will be reset if the current context is not Pure). + -- We also pretend there was a pragma Pure_Function so that for purposes + -- of optimization and constant-folding, we will consider the function + -- Pure even if we are not in a Pure context). + + Set_Is_Pure (Fent); + Set_Has_Pragma_Pure_Function (Fent); + + -- Unless we are in -gnatD mode, where we are debugging generated code, + -- this is an internal entity for which we don't need debug info. + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Fent); + end if; + + Ghost_Mode := Save_Ghost_Mode; + + exception + when RE_Not_Available => + Ghost_Mode := Save_Ghost_Mode; + return; + end Expand_Freeze_Enumeration_Type; + + ------------------------------- + -- Expand_Freeze_Record_Type -- + ------------------------------- + + procedure Expand_Freeze_Record_Type (N : Node_Id) is + Typ : constant Node_Id := Entity (N); + Typ_Decl : constant Node_Id := Parent (Typ); + + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + + Comp : Entity_Id; + Comp_Typ : Entity_Id; + Has_AACC : Boolean; + Predef_List : List_Id; + + Renamed_Eq : Node_Id := Empty; + -- Defining unit name for the predefined equality function in the case + -- where the type has a primitive operation that is a renaming of + -- predefined equality (but only if there is also an overriding + -- user-defined equality function). Used to pass this entity from + -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies. + + Wrapper_Decl_List : List_Id := No_List; + Wrapper_Body_List : List_Id := No_List; + + -- Start of processing for Expand_Freeze_Record_Type + + begin + -- Ensure that all freezing activities are properly flagged as Ghost + + Set_Ghost_Mode_From_Entity (Typ); + + -- Build discriminant checking functions if not a derived type (for + -- derived types that are not tagged types, always use the discriminant + -- checking functions of the parent type). However, for untagged types + -- the derivation may have taken place before the parent was frozen, so + -- we copy explicitly the discriminant checking functions from the + -- parent into the components of the derived type. + + if not Is_Derived_Type (Typ) + or else Has_New_Non_Standard_Rep (Typ) + or else Is_Tagged_Type (Typ) then - Set_Component_Items (Comp_List, New_List (Comp_Decl)); - Set_Null_Present (Comp_List, False); + Build_Discr_Checking_Funcs (Typ_Decl); - else - Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); + elsif Is_Derived_Type (Typ) + and then not Is_Tagged_Type (Typ) + + -- If we have a derived Unchecked_Union, we do not inherit the + -- discriminant checking functions from the parent type since the + -- discriminants are non existent. + + and then not Is_Unchecked_Union (Typ) + and then Has_Discriminants (Typ) + then + declare + Old_Comp : Entity_Id; + + begin + Old_Comp := + First_Component (Base_Type (Underlying_Type (Etype (Typ)))); + Comp := First_Component (Typ); + while Present (Comp) loop + if Ekind (Comp) = E_Component + and then Chars (Comp) = Chars (Old_Comp) + then + Set_Discriminant_Checking_Func (Comp, + Discriminant_Checking_Func (Old_Comp)); + end if; + + Next_Component (Old_Comp); + Next_Component (Comp); + end loop; + end; end if; - Analyze (Comp_Decl); - end Expand_Record_Extension; + if Is_Derived_Type (Typ) + and then Is_Limited_Type (Typ) + and then Is_Tagged_Type (Typ) + then + Check_Stream_Attributes (Typ); + end if; + + -- Update task, protected, and controlled component flags, because some + -- of the component types may have been private at the point of the + -- record declaration. Detect anonymous access-to-controlled components. + + Has_AACC := False; + + Comp := First_Component (Typ); + while Present (Comp) loop + Comp_Typ := Etype (Comp); + + if Has_Task (Comp_Typ) then + Set_Has_Task (Typ); + end if; + + if Has_Protected (Comp_Typ) then + Set_Has_Protected (Typ); + end if; + + -- Do not set Has_Controlled_Component on a class-wide equivalent + -- type. See Make_CW_Equivalent_Type. + + if not Is_Class_Wide_Equivalent_Type (Typ) + and then + (Has_Controlled_Component (Comp_Typ) + or else (Chars (Comp) /= Name_uParent + and then (Is_Controlled_Active (Comp_Typ)))) + then + Set_Has_Controlled_Component (Typ); + end if; + + -- Non-self-referential anonymous access-to-controlled component + + if Ekind (Comp_Typ) = E_Anonymous_Access_Type + and then Needs_Finalization (Designated_Type (Comp_Typ)) + and then Designated_Type (Comp_Typ) /= Typ + then + Has_AACC := True; + end if; + + Next_Component (Comp); + end loop; + + -- Handle constructors of untagged CPP_Class types + + if not Is_Tagged_Type (Typ) and then Is_CPP_Class (Typ) then + Set_CPP_Constructors (Typ); + end if; + + -- Creation of the Dispatch Table. Note that a Dispatch Table is built + -- for regular tagged types as well as for Ada types deriving from a C++ + -- Class, but not for tagged types directly corresponding to C++ classes + -- In the later case we assume that it is created in the C++ side and we + -- just use it. + + if Is_Tagged_Type (Typ) then + + -- Add the _Tag component + + if Underlying_Type (Etype (Typ)) = Typ then + Expand_Tagged_Root (Typ); + end if; + + if Is_CPP_Class (Typ) then + Set_All_DT_Position (Typ); + + -- Create the tag entities with a minimum decoration + + if Tagged_Type_Expansion then + Append_Freeze_Actions (Typ, Make_Tags (Typ)); + end if; + + Set_CPP_Constructors (Typ); + + else + if not Building_Static_DT (Typ) then + + -- Usually inherited primitives are not delayed but the first + -- Ada extension of a CPP_Class is an exception since the + -- address of the inherited subprogram has to be inserted in + -- the new Ada Dispatch Table and this is a freezing action. + + -- Similarly, if this is an inherited operation whose parent is + -- not frozen yet, it is not in the DT of the parent, and we + -- generate an explicit freeze node for the inherited operation + -- so it is properly inserted in the DT of the current type. + + declare + Elmt : Elmt_Id; + Subp : Entity_Id; + + begin + Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Elmt) loop + Subp := Node (Elmt); + + if Present (Alias (Subp)) then + if Is_CPP_Class (Etype (Typ)) then + Set_Has_Delayed_Freeze (Subp); + + elsif Has_Delayed_Freeze (Alias (Subp)) + and then not Is_Frozen (Alias (Subp)) + then + Set_Is_Frozen (Subp, False); + Set_Has_Delayed_Freeze (Subp); + end if; + end if; + + Next_Elmt (Elmt); + end loop; + end; + end if; + + -- Unfreeze momentarily the type to add the predefined primitives + -- operations. The reason we unfreeze is so that these predefined + -- operations will indeed end up as primitive operations (which + -- must be before the freeze point). + + Set_Is_Frozen (Typ, False); + + -- Do not add the spec of predefined primitives in case of + -- CPP tagged type derivations that have convention CPP. + + if Is_CPP_Class (Root_Type (Typ)) + and then Convention (Typ) = Convention_CPP + then + null; + + -- Do not add the spec of the predefined primitives if we are + -- compiling under restriction No_Dispatching_Calls. + + elsif not Restriction_Active (No_Dispatching_Calls) then + Make_Predefined_Primitive_Specs (Typ, Predef_List, Renamed_Eq); + Insert_List_Before_And_Analyze (N, Predef_List); + end if; + + -- Ada 2005 (AI-391): For a nonabstract null extension, create + -- wrapper functions for each nonoverridden inherited function + -- with a controlling result of the type. The wrapper for such + -- a function returns an extension aggregate that invokes the + -- parent function. + + if Ada_Version >= Ada_2005 + and then not Is_Abstract_Type (Typ) + and then Is_Null_Extension (Typ) + then + Make_Controlling_Function_Wrappers + (Typ, Wrapper_Decl_List, Wrapper_Body_List); + Insert_List_Before_And_Analyze (N, Wrapper_Decl_List); + end if; + + -- Ada 2005 (AI-251): For a nonabstract type extension, build + -- null procedure declarations for each set of homographic null + -- procedures that are inherited from interface types but not + -- overridden. This is done to ensure that the dispatch table + -- entry associated with such null primitives are properly filled. + + if Ada_Version >= Ada_2005 + and then Etype (Typ) /= Typ + and then not Is_Abstract_Type (Typ) + and then Has_Interfaces (Typ) + then + Insert_Actions (N, Make_Null_Procedure_Specs (Typ)); + end if; + + Set_Is_Frozen (Typ); + + if not Is_Derived_Type (Typ) + or else Is_Tagged_Type (Etype (Typ)) + then + Set_All_DT_Position (Typ); + + -- If this is a type derived from an untagged private type whose + -- full view is tagged, the type is marked tagged for layout + -- reasons, but it has no dispatch table. + + elsif Is_Derived_Type (Typ) + and then Is_Private_Type (Etype (Typ)) + and then not Is_Tagged_Type (Etype (Typ)) + then + return; + end if; + + -- Create and decorate the tags. Suppress their creation when + -- not Tagged_Type_Expansion because the dispatching mechanism is + -- handled internally by the virtual target. + + if Tagged_Type_Expansion then + Append_Freeze_Actions (Typ, Make_Tags (Typ)); + + -- Generate dispatch table of locally defined tagged type. + -- Dispatch tables of library level tagged types are built + -- later (see Analyze_Declarations). + + if not Building_Static_DT (Typ) then + Append_Freeze_Actions (Typ, Make_DT (Typ)); + end if; + end if; + + -- If the type has unknown discriminants, propagate dispatching + -- information to its underlying record view, which does not get + -- its own dispatch table. + + if Is_Derived_Type (Typ) + and then Has_Unknown_Discriminants (Typ) + and then Present (Underlying_Record_View (Typ)) + then + declare + Rep : constant Entity_Id := Underlying_Record_View (Typ); + begin + Set_Access_Disp_Table + (Rep, Access_Disp_Table (Typ)); + Set_Dispatch_Table_Wrappers + (Rep, Dispatch_Table_Wrappers (Typ)); + Set_Direct_Primitive_Operations + (Rep, Direct_Primitive_Operations (Typ)); + end; + end if; + + -- Make sure that the primitives Initialize, Adjust and Finalize + -- are Frozen before other TSS subprograms. We don't want them + -- Frozen inside. + + if Is_Controlled (Typ) then + if not Is_Limited_Type (Typ) then + Append_Freeze_Actions (Typ, + Freeze_Entity (Find_Prim_Op (Typ, Name_Adjust), Typ)); + end if; + + Append_Freeze_Actions (Typ, + Freeze_Entity (Find_Prim_Op (Typ, Name_Initialize), Typ)); + + Append_Freeze_Actions (Typ, + Freeze_Entity (Find_Prim_Op (Typ, Name_Finalize), Typ)); + end if; + + -- Freeze rest of primitive operations. There is no need to handle + -- the predefined primitives if we are compiling under restriction + -- No_Dispatching_Calls. + + if not Restriction_Active (No_Dispatching_Calls) then + Append_Freeze_Actions (Typ, Predefined_Primitive_Freeze (Typ)); + end if; + end if; + + -- In the untagged case, ever since Ada 83 an equality function must + -- be provided for variant records that are not unchecked unions. + -- In Ada 2012 the equality function composes, and thus must be built + -- explicitly just as for tagged records. + + elsif Has_Discriminants (Typ) + and then not Is_Limited_Type (Typ) + then + declare + Comps : constant Node_Id := + Component_List (Type_Definition (Typ_Decl)); + begin + if Present (Comps) + and then Present (Variant_Part (Comps)) + then + Build_Variant_Record_Equality (Typ); + end if; + end; + + -- Otherwise create primitive equality operation (AI05-0123) + + -- This is done unconditionally to ensure that tools can be linked + -- properly with user programs compiled with older language versions. + -- In addition, this is needed because "=" composes for bounded strings + -- in all language versions (see Exp_Ch4.Expand_Composite_Equality). + + elsif Comes_From_Source (Typ) + and then Convention (Typ) = Convention_Ada + and then not Is_Limited_Type (Typ) + then + Build_Untagged_Equality (Typ); + end if; + + -- Before building the record initialization procedure, if we are + -- dealing with a concurrent record value type, then we must go through + -- the discriminants, exchanging discriminals between the concurrent + -- type and the concurrent record value type. See the section "Handling + -- of Discriminants" in the Einfo spec for details. + + if Is_Concurrent_Record_Type (Typ) + and then Has_Discriminants (Typ) + then + declare + Ctyp : constant Entity_Id := + Corresponding_Concurrent_Type (Typ); + Conc_Discr : Entity_Id; + Rec_Discr : Entity_Id; + Temp : Entity_Id; + + begin + Conc_Discr := First_Discriminant (Ctyp); + Rec_Discr := First_Discriminant (Typ); + while Present (Conc_Discr) loop + Temp := Discriminal (Conc_Discr); + Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr)); + Set_Discriminal (Rec_Discr, Temp); + + Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr); + Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr); + + Next_Discriminant (Conc_Discr); + Next_Discriminant (Rec_Discr); + end loop; + end; + end if; + + if Has_Controlled_Component (Typ) then + Build_Controlling_Procs (Typ); + end if; + + Adjust_Discriminants (Typ); + + -- Do not need init for interfaces on virtual targets since they're + -- abstract. + + if Tagged_Type_Expansion or else not Is_Interface (Typ) then + Build_Record_Init_Proc (Typ_Decl, Typ); + end if; + + -- For tagged type that are not interfaces, build bodies of primitive + -- operations. Note: do this after building the record initialization + -- procedure, since the primitive operations may need the initialization + -- routine. There is no need to add predefined primitives of interfaces + -- because all their predefined primitives are abstract. + + if Is_Tagged_Type (Typ) and then not Is_Interface (Typ) then + + -- Do not add the body of predefined primitives in case of CPP tagged + -- type derivations that have convention CPP. + + if Is_CPP_Class (Root_Type (Typ)) + and then Convention (Typ) = Convention_CPP + then + null; + + -- Do not add the body of the predefined primitives if we are + -- compiling under restriction No_Dispatching_Calls or if we are + -- compiling a CPP tagged type. + + elsif not Restriction_Active (No_Dispatching_Calls) then + + -- Create the body of TSS primitive Finalize_Address. This must + -- be done before the bodies of all predefined primitives are + -- created. If Typ is limited, Stream_Input and Stream_Read may + -- produce build-in-place allocations and for those the expander + -- needs Finalize_Address. + + Make_Finalize_Address_Body (Typ); + Predef_List := Predefined_Primitive_Bodies (Typ, Renamed_Eq); + Append_Freeze_Actions (Typ, Predef_List); + end if; + + -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden + -- inherited functions, then add their bodies to the freeze actions. + + if Present (Wrapper_Body_List) then + Append_Freeze_Actions (Typ, Wrapper_Body_List); + end if; + + -- Create extra formals for the primitive operations of the type. + -- This must be done before analyzing the body of the initialization + -- procedure, because a self-referential type might call one of these + -- primitives in the body of the init_proc itself. + + declare + Elmt : Elmt_Id; + Subp : Entity_Id; + + begin + Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Elmt) loop + Subp := Node (Elmt); + if not Has_Foreign_Convention (Subp) + and then not Is_Predefined_Dispatching_Operation (Subp) + then + Create_Extra_Formals (Subp); + end if; + + Next_Elmt (Elmt); + end loop; + end; + end if; + + -- Create a heterogeneous finalization master to service the anonymous + -- access-to-controlled components of the record type. + + if Has_AACC then + declare + Encl_Scope : constant Entity_Id := Scope (Typ); + Ins_Node : constant Node_Id := Parent (Typ); + Loc : constant Source_Ptr := Sloc (Typ); + Fin_Mas_Id : Entity_Id; + + Attributes_Set : Boolean := False; + Master_Built : Boolean := False; + -- Two flags which control the creation and initialization of a + -- common heterogeneous master. + + begin + Comp := First_Component (Typ); + while Present (Comp) loop + Comp_Typ := Etype (Comp); + + -- A non-self-referential anonymous access-to-controlled + -- component. + + if Ekind (Comp_Typ) = E_Anonymous_Access_Type + and then Needs_Finalization (Designated_Type (Comp_Typ)) + and then Designated_Type (Comp_Typ) /= Typ + then + -- Build a homogeneous master for the first anonymous + -- access-to-controlled component. This master may be + -- converted into a heterogeneous collection if more + -- components are to follow. + + if not Master_Built then + Master_Built := True; + + -- All anonymous access-to-controlled types allocate + -- on the global pool. Note that the finalization + -- master and the associated storage pool must be set + -- on the root type (both are "root type only"). + + Set_Associated_Storage_Pool + (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object)); + + Build_Finalization_Master + (Typ => Root_Type (Comp_Typ), + For_Anonymous => True, + Context_Scope => Encl_Scope, + Insertion_Node => Ins_Node); + + Fin_Mas_Id := Finalization_Master (Comp_Typ); + + -- Subsequent anonymous access-to-controlled components + -- reuse the available master. + + else + -- All anonymous access-to-controlled types allocate + -- on the global pool. Note that both the finalization + -- master and the associated storage pool must be set + -- on the root type (both are "root type only"). + + Set_Associated_Storage_Pool + (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object)); + + -- Shared the master among multiple components + + Set_Finalization_Master + (Root_Type (Comp_Typ), Fin_Mas_Id); + + -- Convert the master into a heterogeneous collection. + -- Generate: + -- Set_Is_Heterogeneous (); + + if not Attributes_Set then + Attributes_Set := True; + + Insert_Action (Ins_Node, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of + (RTE (RE_Set_Is_Heterogeneous), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Fin_Mas_Id, Loc)))); + end if; + end if; + end if; + + Next_Component (Comp); + end loop; + end; + end if; + + -- Check whether individual components have a defined invariant, and add + -- the corresponding component invariant checks. + + -- Do not create an invariant procedure for some internally generated + -- subtypes, in particular those created for objects of a class-wide + -- type. Such types may have components to which invariant apply, but + -- the corresponding checks will be applied when an object of the parent + -- type is constructed. + + -- Such objects will show up in a class-wide postcondition, and the + -- invariant will be checked, if necessary, upon return from the + -- enclosing subprogram. + + if not Is_Class_Wide_Equivalent_Type (Typ) then + Insert_Component_Invariant_Checks + (N, Typ, Build_Record_Invariant_Proc (Typ, N)); + end if; + + Ghost_Mode := Save_Ghost_Mode; + end Expand_Freeze_Record_Type; ------------------------------------ -- Expand_N_Full_Type_Declaration -- @@ -6204,6 +7211,131 @@ package body Exp_Ch3 is end loop; end Expand_Previous_Access_Type; + ----------------------------- + -- Expand_Record_Extension -- + ----------------------------- + + -- Add a field _parent at the beginning of the record extension. This is + -- used to implement inheritance. Here are some examples of expansion: + + -- 1. no discriminants + -- type T2 is new T1 with null record; + -- gives + -- type T2 is new T1 with record + -- _Parent : T1; + -- end record; + + -- 2. renamed discriminants + -- type T2 (B, C : Int) is new T1 (A => B) with record + -- _Parent : T1 (A => B); + -- D : Int; + -- end; + + -- 3. inherited discriminants + -- type T2 is new T1 with record -- discriminant A inherited + -- _Parent : T1 (A); + -- D : Int; + -- end; + + procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id) is + Indic : constant Node_Id := Subtype_Indication (Def); + Loc : constant Source_Ptr := Sloc (Def); + Rec_Ext_Part : Node_Id := Record_Extension_Part (Def); + Par_Subtype : Entity_Id; + Comp_List : Node_Id; + Comp_Decl : Node_Id; + Parent_N : Node_Id; + D : Entity_Id; + List_Constr : constant List_Id := New_List; + + begin + -- Expand_Record_Extension is called directly from the semantics, so + -- we must check to see whether expansion is active before proceeding, + -- because this affects the visibility of selected components in bodies + -- of instances. + + if not Expander_Active then + return; + end if; + + -- This may be a derivation of an untagged private type whose full + -- view is tagged, in which case the Derived_Type_Definition has no + -- extension part. Build an empty one now. + + if No (Rec_Ext_Part) then + Rec_Ext_Part := + Make_Record_Definition (Loc, + End_Label => Empty, + Component_List => Empty, + Null_Present => True); + + Set_Record_Extension_Part (Def, Rec_Ext_Part); + Mark_Rewrite_Insertion (Rec_Ext_Part); + end if; + + Comp_List := Component_List (Rec_Ext_Part); + + Parent_N := Make_Defining_Identifier (Loc, Name_uParent); + + -- If the derived type inherits its discriminants the type of the + -- _parent field must be constrained by the inherited discriminants + + if Has_Discriminants (T) + and then Nkind (Indic) /= N_Subtype_Indication + and then not Is_Constrained (Entity (Indic)) + then + D := First_Discriminant (T); + while Present (D) loop + Append_To (List_Constr, New_Occurrence_Of (D, Loc)); + Next_Discriminant (D); + end loop; + + Par_Subtype := + Process_Subtype ( + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Entity (Indic), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => List_Constr)), + Def); + + -- Otherwise the original subtype_indication is just what is needed + + else + Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def); + end if; + + Set_Parent_Subtype (T, Par_Subtype); + + Comp_Decl := + Make_Component_Declaration (Loc, + Defining_Identifier => Parent_N, + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => New_Occurrence_Of (Par_Subtype, Loc))); + + if Null_Present (Rec_Ext_Part) then + Set_Component_List (Rec_Ext_Part, + Make_Component_List (Loc, + Component_Items => New_List (Comp_Decl), + Variant_Part => Empty, + Null_Present => False)); + Set_Null_Present (Rec_Ext_Part, False); + + elsif Null_Present (Comp_List) + or else Is_Empty_List (Component_Items (Comp_List)) + then + Set_Component_Items (Comp_List, New_List (Comp_Decl)); + Set_Null_Present (Comp_List, False); + + else + Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); + end if; + + Analyze (Comp_Decl); + end Expand_Record_Extension; + ------------------------ -- Expand_Tagged_Root -- ------------------------ @@ -6262,1106 +7394,6 @@ package body Exp_Ch3 is return; end Expand_Tagged_Root; - ---------------------- - -- Clean_Task_Names -- - ---------------------- - - procedure Clean_Task_Names - (Typ : Entity_Id; - Proc_Id : Entity_Id) - is - begin - if Has_Task (Typ) - and then not Restriction_Active (No_Implicit_Heap_Allocations) - and then not Global_Discard_Names - and then Tagged_Type_Expansion - then - Set_Uses_Sec_Stack (Proc_Id); - end if; - end Clean_Task_Names; - - ------------------------------ - -- Expand_Freeze_Array_Type -- - ------------------------------ - - procedure Expand_Freeze_Array_Type (N : Node_Id) is - Typ : constant Entity_Id := Entity (N); - Base : constant Entity_Id := Base_Type (Typ); - Comp_Typ : constant Entity_Id := Component_Type (Typ); - Ins_Node : Node_Id; - - begin - if not Is_Bit_Packed_Array (Typ) then - - -- If the component contains tasks, so does the array type. This may - -- not be indicated in the array type because the component may have - -- been a private type at the point of definition. Same if component - -- type is controlled or contains protected objects. - - Set_Has_Task (Base, Has_Task (Comp_Typ)); - Set_Has_Protected (Base, Has_Protected (Comp_Typ)); - Set_Has_Controlled_Component - (Base, Has_Controlled_Component - (Comp_Typ) - or else - Is_Controlled (Comp_Typ)); - - if No (Init_Proc (Base)) then - - -- If this is an anonymous array created for a declaration with - -- an initial value, its init_proc will never be called. The - -- initial value itself may have been expanded into assignments, - -- in which case the object declaration is carries the - -- No_Initialization flag. - - if Is_Itype (Base) - and then Nkind (Associated_Node_For_Itype (Base)) = - N_Object_Declaration - and then - (Present (Expression (Associated_Node_For_Itype (Base))) - or else No_Initialization (Associated_Node_For_Itype (Base))) - then - null; - - -- We do not need an init proc for string or wide [wide] string, - -- since the only time these need initialization in normalize or - -- initialize scalars mode, and these types are treated specially - -- and do not need initialization procedures. - - elsif Is_Standard_String_Type (Base) then - null; - - -- Otherwise we have to build an init proc for the subtype - - else - Build_Array_Init_Proc (Base, N); - end if; - end if; - - if Typ = Base then - if Has_Controlled_Component (Base) then - Build_Controlling_Procs (Base); - - if not Is_Limited_Type (Comp_Typ) - and then Number_Dimensions (Typ) = 1 - then - Build_Slice_Assignment (Typ); - end if; - end if; - - -- Create a finalization master to service the anonymous access - -- components of the array. - - if Ekind (Comp_Typ) = E_Anonymous_Access_Type - and then Needs_Finalization (Designated_Type (Comp_Typ)) - then - -- The finalization master is inserted before the declaration - -- of the array type. The only exception to this is when the - -- array type is an itype, in which case the master appears - -- before the related context. - - if Is_Itype (Typ) then - Ins_Node := Associated_Node_For_Itype (Typ); - else - Ins_Node := Parent (Typ); - end if; - - Build_Finalization_Master - (Typ => Comp_Typ, - For_Anonymous => True, - Context_Scope => Scope (Typ), - Insertion_Node => Ins_Node); - end if; - end if; - - -- For packed case, default initialization, except if the component type - -- is itself a packed structure with an initialization procedure, or - -- initialize/normalize scalars active, and we have a base type, or the - -- type is public, because in that case a client might specify - -- Normalize_Scalars and there better be a public Init_Proc for it. - - elsif (Present (Init_Proc (Component_Type (Base))) - and then No (Base_Init_Proc (Base))) - or else (Init_Or_Norm_Scalars and then Base = Typ) - or else Is_Public (Typ) - then - Build_Array_Init_Proc (Base, N); - end if; - - if Has_Invariants (Component_Type (Base)) - and then Typ = Base - and then In_Open_Scopes (Scope (Component_Type (Base))) - then - -- Generate component invariant checking procedure. This is only - -- relevant if the array type is within the scope of the component - -- type. Otherwise an array object can only be built using the public - -- subprograms for the component type, and calls to those will have - -- invariant checks. The invariant procedure is only generated for - -- a base type, not a subtype. - - Insert_Component_Invariant_Checks - (N, Base, Build_Array_Invariant_Proc (Base, N)); - end if; - end Expand_Freeze_Array_Type; - - ----------------------------------- - -- Expand_Freeze_Class_Wide_Type -- - ----------------------------------- - - procedure Expand_Freeze_Class_Wide_Type (N : Node_Id) is - Typ : constant Entity_Id := Entity (N); - Root : constant Entity_Id := Root_Type (Typ); - - function Is_C_Derivation (Typ : Entity_Id) return Boolean; - -- Given a type, determine whether it is derived from a C or C++ root - - --------------------- - -- Is_C_Derivation -- - --------------------- - - function Is_C_Derivation (Typ : Entity_Id) return Boolean is - T : Entity_Id; - - begin - T := Typ; - loop - if Is_CPP_Class (T) - or else Convention (T) = Convention_C - or else Convention (T) = Convention_CPP - then - return True; - end if; - - exit when T = Etype (T); - - T := Etype (T); - end loop; - - return False; - end Is_C_Derivation; - - -- Start of processing for Expand_Freeze_Class_Wide_Type - - begin - -- Certain run-time configurations and targets do not provide support - -- for controlled types. - - if Restriction_Active (No_Finalization) then - return; - - -- Do not create TSS routine Finalize_Address when dispatching calls are - -- disabled since the core of the routine is a dispatching call. - - elsif Restriction_Active (No_Dispatching_Calls) then - return; - - -- Do not create TSS routine Finalize_Address for concurrent class-wide - -- types. Ignore C, C++, CIL and Java types since it is assumed that the - -- non-Ada side will handle their destruction. - - elsif Is_Concurrent_Type (Root) - or else Is_C_Derivation (Root) - or else Convention (Typ) = Convention_CPP - then - return; - - -- Do not create TSS routine Finalize_Address when compiling in CodePeer - -- mode since the routine contains an Unchecked_Conversion. - - elsif CodePeer_Mode then - return; - end if; - - -- Create the body of TSS primitive Finalize_Address. This automatically - -- sets the TSS entry for the class-wide type. - - Make_Finalize_Address_Body (Typ); - end Expand_Freeze_Class_Wide_Type; - - ------------------------------------ - -- Expand_Freeze_Enumeration_Type -- - ------------------------------------ - - procedure Expand_Freeze_Enumeration_Type (N : Node_Id) is - Typ : constant Entity_Id := Entity (N); - Loc : constant Source_Ptr := Sloc (Typ); - Ent : Entity_Id; - Lst : List_Id; - Num : Nat; - Arr : Entity_Id; - Fent : Entity_Id; - Ityp : Entity_Id; - Is_Contiguous : Boolean; - Pos_Expr : Node_Id; - Last_Repval : Uint; - - Func : Entity_Id; - pragma Warnings (Off, Func); - - begin - -- Various optimizations possible if given representation is contiguous - - Is_Contiguous := True; - - Ent := First_Literal (Typ); - Last_Repval := Enumeration_Rep (Ent); - - Next_Literal (Ent); - while Present (Ent) loop - if Enumeration_Rep (Ent) - Last_Repval /= 1 then - Is_Contiguous := False; - exit; - else - Last_Repval := Enumeration_Rep (Ent); - end if; - - Next_Literal (Ent); - end loop; - - if Is_Contiguous then - Set_Has_Contiguous_Rep (Typ); - Ent := First_Literal (Typ); - Num := 1; - Lst := New_List (New_Occurrence_Of (Ent, Sloc (Ent))); - - else - -- Build list of literal references - - Lst := New_List; - Num := 0; - - Ent := First_Literal (Typ); - while Present (Ent) loop - Append_To (Lst, New_Occurrence_Of (Ent, Sloc (Ent))); - Num := Num + 1; - Next_Literal (Ent); - end loop; - end if; - - -- Now build an array declaration - - -- typA : array (Natural range 0 .. num - 1) of ctype := - -- (v, v, v, v, v, ....) - - -- where ctype is the corresponding integer type. If the representation - -- is contiguous, we only keep the first literal, which provides the - -- offset for Pos_To_Rep computations. - - Arr := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), 'A')); - - Append_Freeze_Action (Typ, - Make_Object_Declaration (Loc, - Defining_Identifier => Arr, - Constant_Present => True, - - Object_Definition => - Make_Constrained_Array_Definition (Loc, - Discrete_Subtype_Definitions => New_List ( - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc), - Constraint => - Make_Range_Constraint (Loc, - Range_Expression => - Make_Range (Loc, - Low_Bound => - Make_Integer_Literal (Loc, 0), - High_Bound => - Make_Integer_Literal (Loc, Num - 1))))), - - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => New_Occurrence_Of (Typ, Loc))), - - Expression => - Make_Aggregate (Loc, - Expressions => Lst))); - - Set_Enum_Pos_To_Rep (Typ, Arr); - - -- Now we build the function that converts representation values to - -- position values. This function has the form: - - -- function _Rep_To_Pos (A : etype; F : Boolean) return Integer is - -- begin - -- case ityp!(A) is - -- when enum-lit'Enum_Rep => return posval; - -- when enum-lit'Enum_Rep => return posval; - -- ... - -- when others => - -- [raise Constraint_Error when F "invalid data"] - -- return -1; - -- end case; - -- end; - - -- Note: the F parameter determines whether the others case (no valid - -- representation) raises Constraint_Error or returns a unique value - -- of minus one. The latter case is used, e.g. in 'Valid code. - - -- Note: the reason we use Enum_Rep values in the case here is to avoid - -- the code generator making inappropriate assumptions about the range - -- of the values in the case where the value is invalid. ityp is a - -- signed or unsigned integer type of appropriate width. - - -- Note: if exceptions are not supported, then we suppress the raise - -- and return -1 unconditionally (this is an erroneous program in any - -- case and there is no obligation to raise Constraint_Error here). We - -- also do this if pragma Restrictions (No_Exceptions) is active. - - -- Is this right??? What about No_Exception_Propagation??? - - -- Representations are signed - - if Enumeration_Rep (First_Literal (Typ)) < 0 then - - -- The underlying type is signed. Reset the Is_Unsigned_Type - -- explicitly, because it might have been inherited from - -- parent type. - - Set_Is_Unsigned_Type (Typ, False); - - if Esize (Typ) <= Standard_Integer_Size then - Ityp := Standard_Integer; - else - Ityp := Universal_Integer; - end if; - - -- Representations are unsigned - - else - if Esize (Typ) <= Standard_Integer_Size then - Ityp := RTE (RE_Unsigned); - else - Ityp := RTE (RE_Long_Long_Unsigned); - end if; - end if; - - -- The body of the function is a case statement. First collect case - -- alternatives, or optimize the contiguous case. - - Lst := New_List; - - -- If representation is contiguous, Pos is computed by subtracting - -- the representation of the first literal. - - if Is_Contiguous then - Ent := First_Literal (Typ); - - if Enumeration_Rep (Ent) = Last_Repval then - - -- Another special case: for a single literal, Pos is zero - - Pos_Expr := Make_Integer_Literal (Loc, Uint_0); - - else - Pos_Expr := - Convert_To (Standard_Integer, - Make_Op_Subtract (Loc, - Left_Opnd => - Unchecked_Convert_To - (Ityp, Make_Identifier (Loc, Name_uA)), - Right_Opnd => - Make_Integer_Literal (Loc, - Intval => Enumeration_Rep (First_Literal (Typ))))); - end if; - - Append_To (Lst, - Make_Case_Statement_Alternative (Loc, - Discrete_Choices => New_List ( - Make_Range (Sloc (Enumeration_Rep_Expr (Ent)), - Low_Bound => - Make_Integer_Literal (Loc, - Intval => Enumeration_Rep (Ent)), - High_Bound => - Make_Integer_Literal (Loc, Intval => Last_Repval))), - - Statements => New_List ( - Make_Simple_Return_Statement (Loc, - Expression => Pos_Expr)))); - - else - Ent := First_Literal (Typ); - while Present (Ent) loop - Append_To (Lst, - Make_Case_Statement_Alternative (Loc, - Discrete_Choices => New_List ( - Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)), - Intval => Enumeration_Rep (Ent))), - - Statements => New_List ( - Make_Simple_Return_Statement (Loc, - Expression => - Make_Integer_Literal (Loc, - Intval => Enumeration_Pos (Ent)))))); - - Next_Literal (Ent); - end loop; - end if; - - -- In normal mode, add the others clause with the test - - if not No_Exception_Handlers_Set then - Append_To (Lst, - Make_Case_Statement_Alternative (Loc, - Discrete_Choices => New_List (Make_Others_Choice (Loc)), - Statements => New_List ( - Make_Raise_Constraint_Error (Loc, - Condition => Make_Identifier (Loc, Name_uF), - Reason => CE_Invalid_Data), - Make_Simple_Return_Statement (Loc, - Expression => - Make_Integer_Literal (Loc, -1))))); - - -- If either of the restrictions No_Exceptions_Handlers/Propagation is - -- active then return -1 (we cannot usefully raise Constraint_Error in - -- this case). See description above for further details. - - else - Append_To (Lst, - Make_Case_Statement_Alternative (Loc, - Discrete_Choices => New_List (Make_Others_Choice (Loc)), - Statements => New_List ( - Make_Simple_Return_Statement (Loc, - Expression => - Make_Integer_Literal (Loc, -1))))); - end if; - - -- Now we can build the function body - - Fent := - Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos)); - - Func := - Make_Subprogram_Body (Loc, - Specification => - Make_Function_Specification (Loc, - Defining_Unit_Name => Fent, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uA), - Parameter_Type => New_Occurrence_Of (Typ, Loc)), - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uF), - Parameter_Type => - New_Occurrence_Of (Standard_Boolean, Loc))), - - Result_Definition => New_Occurrence_Of (Standard_Integer, Loc)), - - Declarations => Empty_List, - - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Case_Statement (Loc, - Expression => - Unchecked_Convert_To - (Ityp, Make_Identifier (Loc, Name_uA)), - Alternatives => Lst)))); - - Set_TSS (Typ, Fent); - - -- Set Pure flag (it will be reset if the current context is not Pure). - -- We also pretend there was a pragma Pure_Function so that for purposes - -- of optimization and constant-folding, we will consider the function - -- Pure even if we are not in a Pure context). - - Set_Is_Pure (Fent); - Set_Has_Pragma_Pure_Function (Fent); - - -- Unless we are in -gnatD mode, where we are debugging generated code, - -- this is an internal entity for which we don't need debug info. - - if not Debug_Generated_Code then - Set_Debug_Info_Off (Fent); - end if; - - exception - when RE_Not_Available => - return; - end Expand_Freeze_Enumeration_Type; - - ------------------------------- - -- Expand_Freeze_Record_Type -- - ------------------------------- - - procedure Expand_Freeze_Record_Type (N : Node_Id) is - Def_Id : constant Node_Id := Entity (N); - Type_Decl : constant Node_Id := Parent (Def_Id); - Comp : Entity_Id; - Comp_Typ : Entity_Id; - Has_AACC : Boolean; - Predef_List : List_Id; - - Renamed_Eq : Node_Id := Empty; - -- Defining unit name for the predefined equality function in the case - -- where the type has a primitive operation that is a renaming of - -- predefined equality (but only if there is also an overriding - -- user-defined equality function). Used to pass this entity from - -- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies. - - Wrapper_Decl_List : List_Id := No_List; - Wrapper_Body_List : List_Id := No_List; - - -- Start of processing for Expand_Freeze_Record_Type - - begin - -- Build discriminant checking functions if not a derived type (for - -- derived types that are not tagged types, always use the discriminant - -- checking functions of the parent type). However, for untagged types - -- the derivation may have taken place before the parent was frozen, so - -- we copy explicitly the discriminant checking functions from the - -- parent into the components of the derived type. - - if not Is_Derived_Type (Def_Id) - or else Has_New_Non_Standard_Rep (Def_Id) - or else Is_Tagged_Type (Def_Id) - then - Build_Discr_Checking_Funcs (Type_Decl); - - elsif Is_Derived_Type (Def_Id) - and then not Is_Tagged_Type (Def_Id) - - -- If we have a derived Unchecked_Union, we do not inherit the - -- discriminant checking functions from the parent type since the - -- discriminants are non existent. - - and then not Is_Unchecked_Union (Def_Id) - and then Has_Discriminants (Def_Id) - then - declare - Old_Comp : Entity_Id; - - begin - Old_Comp := - First_Component (Base_Type (Underlying_Type (Etype (Def_Id)))); - Comp := First_Component (Def_Id); - while Present (Comp) loop - if Ekind (Comp) = E_Component - and then Chars (Comp) = Chars (Old_Comp) - then - Set_Discriminant_Checking_Func (Comp, - Discriminant_Checking_Func (Old_Comp)); - end if; - - Next_Component (Old_Comp); - Next_Component (Comp); - end loop; - end; - end if; - - if Is_Derived_Type (Def_Id) - and then Is_Limited_Type (Def_Id) - and then Is_Tagged_Type (Def_Id) - then - Check_Stream_Attributes (Def_Id); - end if; - - -- Update task, protected, and controlled component flags, because some - -- of the component types may have been private at the point of the - -- record declaration. Detect anonymous access-to-controlled components. - - Has_AACC := False; - - Comp := First_Component (Def_Id); - while Present (Comp) loop - Comp_Typ := Etype (Comp); - - if Has_Task (Comp_Typ) then - Set_Has_Task (Def_Id); - end if; - - if Has_Protected (Comp_Typ) then - Set_Has_Protected (Def_Id); - end if; - - -- Do not set Has_Controlled_Component on a class-wide equivalent - -- type. See Make_CW_Equivalent_Type. - - if not Is_Class_Wide_Equivalent_Type (Def_Id) - and then - (Has_Controlled_Component (Comp_Typ) - or else (Chars (Comp) /= Name_uParent - and then (Is_Controlled_Active (Comp_Typ)))) - then - Set_Has_Controlled_Component (Def_Id); - end if; - - -- Non-self-referential anonymous access-to-controlled component - - if Ekind (Comp_Typ) = E_Anonymous_Access_Type - and then Needs_Finalization (Designated_Type (Comp_Typ)) - and then Designated_Type (Comp_Typ) /= Def_Id - then - Has_AACC := True; - end if; - - Next_Component (Comp); - end loop; - - -- Handle constructors of untagged CPP_Class types - - if not Is_Tagged_Type (Def_Id) and then Is_CPP_Class (Def_Id) then - Set_CPP_Constructors (Def_Id); - end if; - - -- Creation of the Dispatch Table. Note that a Dispatch Table is built - -- for regular tagged types as well as for Ada types deriving from a C++ - -- Class, but not for tagged types directly corresponding to C++ classes - -- In the later case we assume that it is created in the C++ side and we - -- just use it. - - if Is_Tagged_Type (Def_Id) then - - -- Add the _Tag component - - if Underlying_Type (Etype (Def_Id)) = Def_Id then - Expand_Tagged_Root (Def_Id); - end if; - - if Is_CPP_Class (Def_Id) then - Set_All_DT_Position (Def_Id); - - -- Create the tag entities with a minimum decoration - - if Tagged_Type_Expansion then - Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id)); - end if; - - Set_CPP_Constructors (Def_Id); - - else - if not Building_Static_DT (Def_Id) then - - -- Usually inherited primitives are not delayed but the first - -- Ada extension of a CPP_Class is an exception since the - -- address of the inherited subprogram has to be inserted in - -- the new Ada Dispatch Table and this is a freezing action. - - -- Similarly, if this is an inherited operation whose parent is - -- not frozen yet, it is not in the DT of the parent, and we - -- generate an explicit freeze node for the inherited operation - -- so it is properly inserted in the DT of the current type. - - declare - Elmt : Elmt_Id; - Subp : Entity_Id; - - begin - Elmt := First_Elmt (Primitive_Operations (Def_Id)); - while Present (Elmt) loop - Subp := Node (Elmt); - - if Present (Alias (Subp)) then - if Is_CPP_Class (Etype (Def_Id)) then - Set_Has_Delayed_Freeze (Subp); - - elsif Has_Delayed_Freeze (Alias (Subp)) - and then not Is_Frozen (Alias (Subp)) - then - Set_Is_Frozen (Subp, False); - Set_Has_Delayed_Freeze (Subp); - end if; - end if; - - Next_Elmt (Elmt); - end loop; - end; - end if; - - -- Unfreeze momentarily the type to add the predefined primitives - -- operations. The reason we unfreeze is so that these predefined - -- operations will indeed end up as primitive operations (which - -- must be before the freeze point). - - Set_Is_Frozen (Def_Id, False); - - -- Do not add the spec of predefined primitives in case of - -- CPP tagged type derivations that have convention CPP. - - if Is_CPP_Class (Root_Type (Def_Id)) - and then Convention (Def_Id) = Convention_CPP - then - null; - - -- Do not add the spec of the predefined primitives if we are - -- compiling under restriction No_Dispatching_Calls. - - elsif not Restriction_Active (No_Dispatching_Calls) then - Make_Predefined_Primitive_Specs - (Def_Id, Predef_List, Renamed_Eq); - Insert_List_Before_And_Analyze (N, Predef_List); - end if; - - -- Ada 2005 (AI-391): For a nonabstract null extension, create - -- wrapper functions for each nonoverridden inherited function - -- with a controlling result of the type. The wrapper for such - -- a function returns an extension aggregate that invokes the - -- parent function. - - if Ada_Version >= Ada_2005 - and then not Is_Abstract_Type (Def_Id) - and then Is_Null_Extension (Def_Id) - then - Make_Controlling_Function_Wrappers - (Def_Id, Wrapper_Decl_List, Wrapper_Body_List); - Insert_List_Before_And_Analyze (N, Wrapper_Decl_List); - end if; - - -- Ada 2005 (AI-251): For a nonabstract type extension, build - -- null procedure declarations for each set of homographic null - -- procedures that are inherited from interface types but not - -- overridden. This is done to ensure that the dispatch table - -- entry associated with such null primitives are properly filled. - - if Ada_Version >= Ada_2005 - and then Etype (Def_Id) /= Def_Id - and then not Is_Abstract_Type (Def_Id) - and then Has_Interfaces (Def_Id) - then - Insert_Actions (N, Make_Null_Procedure_Specs (Def_Id)); - end if; - - Set_Is_Frozen (Def_Id); - if not Is_Derived_Type (Def_Id) - or else Is_Tagged_Type (Etype (Def_Id)) - then - Set_All_DT_Position (Def_Id); - - -- If this is a type derived from an untagged private type whose - -- full view is tagged, the type is marked tagged for layout - -- reasons, but it has no dispatch table. - - elsif Is_Derived_Type (Def_Id) - and then Is_Private_Type (Etype (Def_Id)) - and then not Is_Tagged_Type (Etype (Def_Id)) - then - return; - end if; - - -- Create and decorate the tags. Suppress their creation when - -- not Tagged_Type_Expansion because the dispatching mechanism is - -- handled internally by the virtual target. - - if Tagged_Type_Expansion then - Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id)); - - -- Generate dispatch table of locally defined tagged type. - -- Dispatch tables of library level tagged types are built - -- later (see Analyze_Declarations). - - if not Building_Static_DT (Def_Id) then - Append_Freeze_Actions (Def_Id, Make_DT (Def_Id)); - end if; - end if; - - -- If the type has unknown discriminants, propagate dispatching - -- information to its underlying record view, which does not get - -- its own dispatch table. - - if Is_Derived_Type (Def_Id) - and then Has_Unknown_Discriminants (Def_Id) - and then Present (Underlying_Record_View (Def_Id)) - then - declare - Rep : constant Entity_Id := Underlying_Record_View (Def_Id); - begin - Set_Access_Disp_Table - (Rep, Access_Disp_Table (Def_Id)); - Set_Dispatch_Table_Wrappers - (Rep, Dispatch_Table_Wrappers (Def_Id)); - Set_Direct_Primitive_Operations - (Rep, Direct_Primitive_Operations (Def_Id)); - end; - end if; - - -- Make sure that the primitives Initialize, Adjust and Finalize - -- are Frozen before other TSS subprograms. We don't want them - -- Frozen inside. - - if Is_Controlled (Def_Id) then - if not Is_Limited_Type (Def_Id) then - Append_Freeze_Actions (Def_Id, - Freeze_Entity - (Find_Prim_Op (Def_Id, Name_Adjust), Def_Id)); - end if; - - Append_Freeze_Actions (Def_Id, - Freeze_Entity - (Find_Prim_Op (Def_Id, Name_Initialize), Def_Id)); - - Append_Freeze_Actions (Def_Id, - Freeze_Entity - (Find_Prim_Op (Def_Id, Name_Finalize), Def_Id)); - end if; - - -- Freeze rest of primitive operations. There is no need to handle - -- the predefined primitives if we are compiling under restriction - -- No_Dispatching_Calls. - - if not Restriction_Active (No_Dispatching_Calls) then - Append_Freeze_Actions - (Def_Id, Predefined_Primitive_Freeze (Def_Id)); - end if; - end if; - - -- In the untagged case, ever since Ada 83 an equality function must - -- be provided for variant records that are not unchecked unions. - -- In Ada 2012 the equality function composes, and thus must be built - -- explicitly just as for tagged records. - - elsif Has_Discriminants (Def_Id) - and then not Is_Limited_Type (Def_Id) - then - declare - Comps : constant Node_Id := - Component_List (Type_Definition (Type_Decl)); - begin - if Present (Comps) - and then Present (Variant_Part (Comps)) - then - Build_Variant_Record_Equality (Def_Id); - end if; - end; - - -- Otherwise create primitive equality operation (AI05-0123) - - -- This is done unconditionally to ensure that tools can be linked - -- properly with user programs compiled with older language versions. - -- In addition, this is needed because "=" composes for bounded strings - -- in all language versions (see Exp_Ch4.Expand_Composite_Equality). - - elsif Comes_From_Source (Def_Id) - and then Convention (Def_Id) = Convention_Ada - and then not Is_Limited_Type (Def_Id) - then - Build_Untagged_Equality (Def_Id); - end if; - - -- Before building the record initialization procedure, if we are - -- dealing with a concurrent record value type, then we must go through - -- the discriminants, exchanging discriminals between the concurrent - -- type and the concurrent record value type. See the section "Handling - -- of Discriminants" in the Einfo spec for details. - - if Is_Concurrent_Record_Type (Def_Id) - and then Has_Discriminants (Def_Id) - then - declare - Ctyp : constant Entity_Id := - Corresponding_Concurrent_Type (Def_Id); - Conc_Discr : Entity_Id; - Rec_Discr : Entity_Id; - Temp : Entity_Id; - - begin - Conc_Discr := First_Discriminant (Ctyp); - Rec_Discr := First_Discriminant (Def_Id); - while Present (Conc_Discr) loop - Temp := Discriminal (Conc_Discr); - Set_Discriminal (Conc_Discr, Discriminal (Rec_Discr)); - Set_Discriminal (Rec_Discr, Temp); - - Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr); - Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr); - - Next_Discriminant (Conc_Discr); - Next_Discriminant (Rec_Discr); - end loop; - end; - end if; - - if Has_Controlled_Component (Def_Id) then - Build_Controlling_Procs (Def_Id); - end if; - - Adjust_Discriminants (Def_Id); - - if Tagged_Type_Expansion or else not Is_Interface (Def_Id) then - - -- Do not need init for interfaces on virtual targets since they're - -- abstract. - - Build_Record_Init_Proc (Type_Decl, Def_Id); - end if; - - -- For tagged type that are not interfaces, build bodies of primitive - -- operations. Note: do this after building the record initialization - -- procedure, since the primitive operations may need the initialization - -- routine. There is no need to add predefined primitives of interfaces - -- because all their predefined primitives are abstract. - - if Is_Tagged_Type (Def_Id) and then not Is_Interface (Def_Id) then - - -- Do not add the body of predefined primitives in case of CPP tagged - -- type derivations that have convention CPP. - - if Is_CPP_Class (Root_Type (Def_Id)) - and then Convention (Def_Id) = Convention_CPP - then - null; - - -- Do not add the body of the predefined primitives if we are - -- compiling under restriction No_Dispatching_Calls or if we are - -- compiling a CPP tagged type. - - elsif not Restriction_Active (No_Dispatching_Calls) then - - -- Create the body of TSS primitive Finalize_Address. This must - -- be done before the bodies of all predefined primitives are - -- created. If Def_Id is limited, Stream_Input and Stream_Read - -- may produce build-in-place allocations and for those the - -- expander needs Finalize_Address. - - Make_Finalize_Address_Body (Def_Id); - Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq); - Append_Freeze_Actions (Def_Id, Predef_List); - end if; - - -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden - -- inherited functions, then add their bodies to the freeze actions. - - if Present (Wrapper_Body_List) then - Append_Freeze_Actions (Def_Id, Wrapper_Body_List); - end if; - - -- Create extra formals for the primitive operations of the type. - -- This must be done before analyzing the body of the initialization - -- procedure, because a self-referential type might call one of these - -- primitives in the body of the init_proc itself. - - declare - Elmt : Elmt_Id; - Subp : Entity_Id; - - begin - Elmt := First_Elmt (Primitive_Operations (Def_Id)); - while Present (Elmt) loop - Subp := Node (Elmt); - if not Has_Foreign_Convention (Subp) - and then not Is_Predefined_Dispatching_Operation (Subp) - then - Create_Extra_Formals (Subp); - end if; - - Next_Elmt (Elmt); - end loop; - end; - end if; - - -- Create a heterogeneous finalization master to service the anonymous - -- access-to-controlled components of the record type. - - if Has_AACC then - declare - Encl_Scope : constant Entity_Id := Scope (Def_Id); - Ins_Node : constant Node_Id := Parent (Def_Id); - Loc : constant Source_Ptr := Sloc (Def_Id); - Fin_Mas_Id : Entity_Id; - - Attributes_Set : Boolean := False; - Master_Built : Boolean := False; - -- Two flags which control the creation and initialization of a - -- common heterogeneous master. - - begin - Comp := First_Component (Def_Id); - while Present (Comp) loop - Comp_Typ := Etype (Comp); - - -- A non-self-referential anonymous access-to-controlled - -- component. - - if Ekind (Comp_Typ) = E_Anonymous_Access_Type - and then Needs_Finalization (Designated_Type (Comp_Typ)) - and then Designated_Type (Comp_Typ) /= Def_Id - then - -- Build a homogeneous master for the first anonymous - -- access-to-controlled component. This master may be - -- converted into a heterogeneous collection if more - -- components are to follow. - - if not Master_Built then - Master_Built := True; - - -- All anonymous access-to-controlled types allocate - -- on the global pool. Note that the finalization - -- master and the associated storage pool must be set - -- on the root type (both are "root type only"). - - Set_Associated_Storage_Pool - (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object)); - - Build_Finalization_Master - (Typ => Root_Type (Comp_Typ), - For_Anonymous => True, - Context_Scope => Encl_Scope, - Insertion_Node => Ins_Node); - - Fin_Mas_Id := Finalization_Master (Comp_Typ); - - -- Subsequent anonymous access-to-controlled components - -- reuse the available master. - - else - -- All anonymous access-to-controlled types allocate - -- on the global pool. Note that both the finalization - -- master and the associated storage pool must be set - -- on the root type (both are "root type only"). - - Set_Associated_Storage_Pool - (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object)); - - -- Shared the master among multiple components - - Set_Finalization_Master - (Root_Type (Comp_Typ), Fin_Mas_Id); - - -- Convert the master into a heterogeneous collection. - -- Generate: - -- Set_Is_Heterogeneous (); - - if not Attributes_Set then - Attributes_Set := True; - - Insert_Action (Ins_Node, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of - (RTE (RE_Set_Is_Heterogeneous), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Fin_Mas_Id, Loc)))); - end if; - end if; - end if; - - Next_Component (Comp); - end loop; - end; - end if; - - -- Check whether individual components have a defined invariant, and add - -- the corresponding component invariant checks. - - -- Do not create an invariant procedure for some internally generated - -- subtypes, in particular those created for objects of a class-wide - -- type. Such types may have components to which invariant apply, but - -- the corresponding checks will be applied when an object of the parent - -- type is constructed. - - -- Such objects will show up in a class-wide postcondition, and the - -- invariant will be checked, if necessary, upon return from the - -- enclosing subprogram. - - if not Is_Class_Wide_Equivalent_Type (Def_Id) then - Insert_Component_Invariant_Checks - (N, Def_Id, Build_Record_Invariant_Proc (Def_Id, N)); - end if; - end Expand_Freeze_Record_Type; - ------------------------------ -- Freeze_Stream_Operations -- ------------------------------ diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 80a7e0d9dde..2688e2e516f 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -7766,6 +7766,12 @@ package body Exp_Ch6 is elsif not Has_Significant_Contract (Subp_Id) then return; + + -- The contract of an ignored Ghost subprogram does not need expansion + -- because the subprogram and all calls to it will be removed. + + elsif Is_Ignored_Ghost_Entity (Subp_Id) then + return; end if; -- Do not re-expand the same contract. This scenario occurs when a diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index 8151923d2c8..2775cef92d9 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -575,9 +575,7 @@ package body Exp_Dbug is -- Couldn't we just test Original_Operating_Mode here? ??? - if Operating_Mode /= Generate_Code - and then not Generating_Code - then + if Operating_Mode /= Generate_Code and then not Generating_Code then return; end if; @@ -641,11 +639,11 @@ package body Exp_Dbug is Lo_Discr : constant Boolean := Nkind (Lo) = N_Identifier - and then Ekind (Entity (Lo)) = E_Discriminant; + and then Ekind (Entity (Lo)) = E_Discriminant; Hi_Discr : constant Boolean := Nkind (Hi) = N_Identifier - and then Ekind (Entity (Hi)) = E_Discriminant; + and then Ekind (Entity (Hi)) = E_Discriminant; Lo_Encode : constant Boolean := Lo_Con or Lo_Discr; Hi_Encode : constant Boolean := Hi_Con or Hi_Discr; @@ -717,11 +715,8 @@ package body Exp_Dbug is procedure Get_External_Name (Entity : Entity_Id; Has_Suffix : Boolean := False; - Suffix : String := "") + Suffix : String := "") is - E : Entity_Id := Entity; - Kind : Entity_Kind; - procedure Get_Qualified_Name_And_Append (Entity : Entity_Id); -- Appends fully qualified name of given entity to Name_Buffer @@ -752,6 +747,10 @@ package body Exp_Dbug is end if; end Get_Qualified_Name_And_Append; + -- Local variables + + E : Entity_Id := Entity; + -- Start of processing for Get_External_Name begin @@ -777,15 +776,25 @@ package body Exp_Dbug is E := Defining_Identifier (Entity); end if; - Kind := Ekind (E); + -- Add a special prefix to distinguish ignored Ghost entities. These + -- entities should not leak in the "living" space and they should be + -- removed by the compiler in a post-processing pass. The prefix is + -- also added to any kind of Ghost entity when switch -gnatd.5 is + -- enabled. + + if Is_Ignored_Ghost_Entity (E) + or else (Debug_Flag_Dot_5 and Is_Ghost_Entity (E)) + then + Add_Str_To_Name_Buffer ("_ghost_"); + end if; -- Case of interface name being used - if (Kind = E_Procedure or else - Kind = E_Function or else - Kind = E_Constant or else - Kind = E_Variable or else - Kind = E_Exception) + if Ekind_In (E, E_Constant, + E_Exception, + E_Function, + E_Procedure, + E_Variable) and then Present (Interface_Name (E)) and then No (Address_Clause (E)) and then not Has_Suffix @@ -816,9 +825,7 @@ package body Exp_Dbug is if Is_Generic_Instance (E) and then Is_Subprogram (E) and then not Is_Compilation_Unit (Scope (E)) - and then (Ekind (Scope (E)) = E_Package - or else - Ekind (Scope (E)) = E_Package_Body) + and then Ekind_In (Scope (E), E_Package, E_Package_Body) and then Present (Related_Instance (Scope (E))) then E := Related_Instance (Scope (E)); diff --git a/gcc/ada/exp_dbug.ads b/gcc/ada/exp_dbug.ads index 352e57ff215..0cca7851325 100644 --- a/gcc/ada/exp_dbug.ads +++ b/gcc/ada/exp_dbug.ads @@ -76,6 +76,12 @@ package Exp_Dbug is -- qualification for such entities. In particular this means that direct -- local variables of a procedure are not qualified. + -- For ignored Ghost entities, the encoding adds a prefix "_ghost_" to aid + -- the detection of leaks in the "living" space. Ignored Ghost entities and + -- any code associated with them should be removed by the compiler in a + -- post-processing pass. As a result, object files should not contain any + -- occurrences of this prefix. + -- As an example of the local name convention, consider a procedure V.W -- with a local variable X, and a nested block Y containing an entity Z. -- The fully qualified names of the entities X and Z are: @@ -414,7 +420,7 @@ package Exp_Dbug is procedure Get_External_Name (Entity : Entity_Id; Has_Suffix : Boolean := False; - Suffix : String := ""); + Suffix : String := ""); -- Set Name_Buffer and Name_Len to the external name of the entity. The -- external name is the Interface_Name, if specified, unless the entity -- has an address clause or Has_Suffix is true. @@ -1185,8 +1191,7 @@ package Exp_Dbug is function Make_Packed_Array_Impl_Type_Name (Typ : Entity_Id; - Csize : Uint) - return Name_Id; + Csize : Uint) return Name_Id; -- This function is used in Exp_Pakd to create the name that is encoded as -- described above. The entity Typ provides the name ttt, and the value -- Csize is the component size that provides the nnn value. diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index e80b5b90ecd..62aa80da005 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -321,6 +321,8 @@ package body Exp_Prag is -- Assert_Failure, so that coverage analysis tools can relate the -- call to the failed check. + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + begin -- Nothing to do if pragma is ignored @@ -328,6 +330,13 @@ package body Exp_Prag is return; end if; + -- Pragmas Assert, Assert_And_Cut, Assume, Check and Loop_Invariant are + -- Ghost when they apply to a Ghost entity. Set the mode now to ensure + -- that any nodes generated during expansion are properly flagged as + -- Ghost. + + Set_Ghost_Mode (N); + -- Since this check is active, we rewrite the pragma into a -- corresponding if statement, and then analyze the statement. @@ -482,7 +491,7 @@ package body Exp_Prag is if Is_Entity_Name (Original_Node (Cond)) and then Entity (Original_Node (Cond)) = Standard_False then - return; + null; elsif Nam = Name_Assert then Error_Msg_N ("?A?assertion will fail at run time", N); @@ -491,6 +500,8 @@ package body Exp_Prag is Error_Msg_N ("?A?check will fail at run time", N); end if; end if; + + Ghost_Mode := Save_Ghost_Mode; end Expand_Pragma_Check; --------------------------------- @@ -1806,6 +1817,14 @@ package body Exp_Prag is Set_Ghost_Mode (N); + -- The expansion of Loop_Variant is quite distributed as it produces + -- various statements to capture and compare the arguments. To preserve + -- the original context, set the Is_Assertion_Expr flag. This aids the + -- Ghost legality checks when verifying the placement of a reference to + -- a Ghost entity. + + In_Assertion_Expr := In_Assertion_Expr + 1; + -- Locate the enclosing loop for which this assertion applies. In the -- case of Ada 2012 array iteration, we might be dealing with nested -- loops. Only the outermost loop has an identifier. @@ -1867,6 +1886,7 @@ package body Exp_Prag is -- corresponding declarations and statements. We leave it in the tree -- for documentation purposes. It will be ignored by the backend. + In_Assertion_Expr := In_Assertion_Expr - 1; Ghost_Mode := Save_Ghost_Mode; end Expand_Pragma_Loop_Variant; diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index 21d94472e24..88de827a90d 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1121,7 +1121,7 @@ package body Exp_Strm is Decl : out Node_Id; Fnam : out Entity_Id) is - B_Typ : constant Entity_Id := Base_Type (Typ); + B_Typ : constant Entity_Id := Underlying_Type (Base_Type (Typ)); Cn : Name_Id; Constr : List_Id; Decls : List_Id; diff --git a/gcc/ada/g-awk.ads b/gcc/ada/g-awk.ads index d6dc83eb64f..c52403e5ddf 100644 --- a/gcc/ada/g-awk.ads +++ b/gcc/ada/g-awk.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2011, AdaCore -- +-- Copyright (C) 2000-2015, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -465,7 +465,7 @@ package GNAT.AWK is Pattern : GNAT.Regpat.Pattern_Matcher; Action : Match_Action_Callback); -- Same as above but it pass the set of matches to the action - -- procedure. This is useful to analyse further why and where a regular + -- procedure. This is useful to analyze further why and where a regular -- expression did match. procedure Register diff --git a/gcc/ada/ghost.adb b/gcc/ada/ghost.adb index 7380d9a9057..cabcc2b32ce 100644 --- a/gcc/ada/ghost.adb +++ b/gcc/ada/ghost.adb @@ -229,11 +229,6 @@ package body Ghost is elsif Is_Subject_To_Ghost (Decl) then return True; - - -- The declaration appears within an assertion expression - - elsif In_Assertion_Expr > 0 then - return True; end if; -- Special cases @@ -338,13 +333,13 @@ package body Ghost is if Is_Ghost_Pragma (Prag) then return True; - -- An assertion expression is a Ghost pragma when it contains a + -- An assertion expression pragma is Ghost when it contains a -- reference to a Ghost entity (SPARK RM 6.9(11)). elsif Assertion_Expression_Pragma (Prag_Id) then -- Predicates are excluded from this category when they do - -- not apply to a Ghost subtype (SPARK RM 6.9(12)). + -- not apply to a Ghost subtype (SPARK RM 6.9(11)). if Nam_In (Prag_Nam, Name_Dynamic_Predicate, Name_Predicate, @@ -413,27 +408,17 @@ package body Ghost is -- Special cases - elsif Nkind (Stmt) = N_If_Statement then + -- An if statement is a suitable context for a Ghost entity if it + -- is the byproduct of assertion expression expansion. Note that + -- the assertion expression may not be related to a Ghost entity, + -- but it may still contain references to Ghost entities. - -- An if statement is a suitable context for a Ghost entity if - -- it is the byproduct of assertion expression expansion. Note - -- that the assertion expression may not be related to a Ghost - -- entity, but it may still contain references to Ghost - -- entities. - - if Nkind (Original_Node (Stmt)) = N_Pragma - and then Assertion_Expression_Pragma - (Get_Pragma_Id (Original_Node (Stmt))) - then - return True; - - -- The expansion of pragma Contract_Cases produces various if - -- statements to evaluate all case guards. This is a suitable - -- context as Contract_Cases is an assertion expression. - - elsif In_Assertion_Expr > 0 then - return True; - end if; + elsif Nkind (Stmt) = N_If_Statement + and then Nkind (Original_Node (Stmt)) = N_Pragma + and then Assertion_Expression_Pragma + (Get_Pragma_Id (Original_Node (Stmt))) + then + return True; end if; return False; @@ -487,13 +472,26 @@ package body Ghost is -- Prevent the search from going too far elsif Is_Body_Or_Package_Declaration (Par) then - return False; + exit; end if; Par := Parent (Par); end loop; - return False; + -- The expansion of assertion expression pragmas and attribute Old + -- may cause a legal Ghost entity reference to become illegal due + -- to node relocation. Check the In_Assertion_Expr counter as last + -- resort to try and infer the original legal context. + + if In_Assertion_Expr > 0 then + return True; + + -- Otherwise the context is not suitable for a reference to a + -- Ghost entity. + + else + return False; + end if; end if; end Is_OK_Ghost_Context; @@ -592,32 +590,32 @@ package body Ghost is (Subp : Entity_Id; Overridden_Subp : Entity_Id) is - Par_Subp : Entity_Id; + Over_Subp : Entity_Id; begin if Present (Subp) and then Present (Overridden_Subp) then - Par_Subp := Ultimate_Alias (Overridden_Subp); + Over_Subp := Ultimate_Alias (Overridden_Subp); -- The Ghost policy in effect at the point of declaration of a parent -- and an overriding subprogram must match (SPARK RM 6.9(17)). - if Is_Checked_Ghost_Entity (Par_Subp) + if Is_Checked_Ghost_Entity (Over_Subp) and then Is_Ignored_Ghost_Entity (Subp) then Error_Msg_N ("incompatible ghost policies in effect", Subp); - Error_Msg_Sloc := Sloc (Par_Subp); + Error_Msg_Sloc := Sloc (Over_Subp); Error_Msg_N ("\& declared # with ghost policy `Check`", Subp); Error_Msg_Sloc := Sloc (Subp); Error_Msg_N ("\overridden # with ghost policy `Ignore`", Subp); - elsif Is_Ignored_Ghost_Entity (Par_Subp) + elsif Is_Ignored_Ghost_Entity (Over_Subp) and then Is_Checked_Ghost_Entity (Subp) then Error_Msg_N ("incompatible ghost policies in effect", Subp); - Error_Msg_Sloc := Sloc (Par_Subp); + Error_Msg_Sloc := Sloc (Over_Subp); Error_Msg_N ("\& declared # with ghost policy `Ignore`", Subp); Error_Msg_Sloc := Sloc (Subp); @@ -686,15 +684,6 @@ package body Ghost is Ignored_Ghost_Units.Init; end Initialize; - --------------------- - -- 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_Subject_To_Ghost -- ------------------------- diff --git a/gcc/ada/ghost.ads b/gcc/ada/ghost.ads index c854629ba82..3dbe5026aea 100644 --- a/gcc/ada/ghost.ads +++ b/gcc/ada/ghost.ads @@ -62,10 +62,6 @@ package Ghost is procedure Initialize; -- Initialize internal tables - function Is_Ghost_Entity (Id : Entity_Id) return Boolean; - -- Determine whether entity Id is Ghost. To qualify as such, the entity - -- must be subject to pragma Ghost. - procedure Lock; -- Lock internal tables before calling backend diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index d3003643f64..8b1287c1ef9 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -7836,7 +7836,7 @@ package body Sem_Ch13 is end if; -- The related type may be subject to pragma Ghost. Set the mode now to - -- ensure that the predicate functions are properly marked as Ghost. + -- ensure that the invariant procedure is properly marked as Ghost. Set_Ghost_Mode_From_Entity (Typ); @@ -7889,23 +7889,11 @@ package body Sem_Ch13 is -- end typInvariant; procedure Build_Invariant_Procedure (Typ : Entity_Id; N : Node_Id) is - Priv_Decls : constant List_Id := Private_Declarations (N); - Vis_Decls : constant List_Id := Visible_Declarations (N); - - Loc : constant Source_Ptr := Sloc (Typ); - Stmts : List_Id; - Spec : Node_Id; - SId : Entity_Id; - PDecl : Node_Id; - PBody : Node_Id; - - Object_Entity : Node_Id; - -- The entity of the formal for the procedure - - Object_Name : Name_Id; - -- Name for argument of invariant procedure - - procedure Add_Invariants (T : Entity_Id; Inherit : Boolean); + procedure Add_Invariants + (T : Entity_Id; + Obj_Id : Entity_Id; + Stmts : in out List_Id; + Inherit : Boolean); -- Appends statements to Stmts for any invariants in the rep item chain -- of the given type. If Inherit is False, then we only process entries -- on the chain for the type Typ. If Inherit is True, then we ignore any @@ -7917,7 +7905,12 @@ package body Sem_Ch13 is -- Add_Invariants -- -------------------- - procedure Add_Invariants (T : Entity_Id; Inherit : Boolean) is + procedure Add_Invariants + (T : Entity_Id; + Obj_Id : Entity_Id; + Stmts : in out List_Id; + Inherit : Boolean) + is procedure Add_Invariant (Prag : Node_Id); -- Create a runtime check to verify the exression of invariant pragma -- Prag. All generated code is added to list Stmts. @@ -7988,17 +7981,18 @@ package body Sem_Ch13 is Make_Attribute_Reference (Nloc, Prefix => New_Occurrence_Of (T, Nloc), Attribute_Name => Name_Class), - Expression => Make_Identifier (Nloc, Object_Name))); + Expression => + Make_Identifier (Nloc, Chars (Obj_Id)))); - Set_Entity (Expression (N), Object_Entity); + Set_Entity (Expression (N), Obj_Id); Set_Etype (Expression (N), Typ); end if; -- Invariant, replace with obj else - Rewrite (N, Make_Identifier (Nloc, Object_Name)); - Set_Entity (N, Object_Entity); + Rewrite (N, Make_Identifier (Nloc, Chars (Obj_Id))); + Set_Entity (N, Obj_Id); Set_Etype (N, Typ); end if; @@ -8190,9 +8184,31 @@ package body Sem_Ch13 is end loop; end Add_Invariants; + -- Local variables + + Loc : constant Source_Ptr := Sloc (Typ); + Priv_Decls : constant List_Id := Private_Declarations (N); + Vis_Decls : constant List_Id := Visible_Declarations (N); + + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; + + PBody : Node_Id; + PDecl : Node_Id; + SId : Entity_Id; + Spec : Node_Id; + Stmts : List_Id; + + Obj_Id : Node_Id; + -- The entity of the formal for the procedure + -- Start of processing for Build_Invariant_Procedure begin + -- The related type may be subject to pragma Ghost. Set the mode now to + -- ensure that the invariant procedure is properly marked as Ghost. + + Set_Ghost_Mode_From_Entity (Typ); + Stmts := No_List; PDecl := Empty; PBody := Empty; @@ -8219,6 +8235,7 @@ package body Sem_Ch13 is and then Nkind (PDecl) = N_Subprogram_Declaration and then Present (Corresponding_Body (PDecl)) then + Ghost_Mode := Save_Ghost_Mode; return; end if; @@ -8229,14 +8246,17 @@ package body Sem_Ch13 is -- Recover formal of procedure, for use in the calls to invariant -- functions (including inherited ones). - Object_Entity := + Obj_Id := Defining_Identifier (First (Parameter_Specifications (Specification (PDecl)))); - Object_Name := Chars (Object_Entity); -- Add invariants for the current type - Add_Invariants (Typ, Inherit => False); + Add_Invariants + (T => Typ, + Obj_Id => Obj_Id, + Stmts => Stmts, + Inherit => False); -- Add invariants for parent types @@ -8258,7 +8278,11 @@ package body Sem_Ch13 is exit when Parent_Typ = Current_Typ; Current_Typ := Parent_Typ; - Add_Invariants (Current_Typ, Inherit => True); + Add_Invariants + (T => Current_Typ, + Obj_Id => Obj_Id, + Stmts => Stmts, + Inherit => True); end loop; end; @@ -8278,7 +8302,11 @@ package body Sem_Ch13 is Iface := Node (AI); if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then - Add_Invariants (Iface, Inherit => True); + Add_Invariants + (T => Iface, + Obj_Id => Obj_Id, + Stmts => Stmts, + Inherit => True); end if; Next_Elmt (AI); @@ -8289,7 +8317,7 @@ package body Sem_Ch13 is -- Build the procedure if we generated at least one Check pragma if Stmts /= No_List then - Spec := Copy_Separate_Tree (Specification (PDecl)); + Spec := Copy_Separate_Tree (Specification (PDecl)); PBody := Make_Subprogram_Body (Loc, @@ -8342,6 +8370,8 @@ package body Sem_Ch13 is Analyze (PBody); end if; end if; + + Ghost_Mode := Save_Ghost_Mode; end Build_Invariant_Procedure; ------------------------------- diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index ea1640004ff..82c3dd8254b 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3441,9 +3441,11 @@ package body Sem_Ch3 is Check_Missing_Part_Of (Obj_Id); end if; - -- A ghost object cannot be imported or exported (SPARK RM 6.9(8)) + -- A ghost object cannot be imported or exported (SPARK RM 6.9(8)). One + -- exception to this is the object that represents the dispatch table of + -- a Ghost tagged type as the symbol needs to be exported. - if Is_Ghost_Entity (Obj_Id) then + if Comes_From_Source (Obj_Id) and then Is_Ghost_Entity (Obj_Id) then if Is_Exported (Obj_Id) then Error_Msg_N ("ghost object & cannot be exported", Obj_Id); @@ -4166,7 +4168,7 @@ package body Sem_Ch3 is -- An object declared within a Ghost region is automatically -- Ghost (SPARK RM 6.9(2)). - if Comes_From_Source (Id) and then Ghost_Mode > None then + if Ghost_Mode > None then Set_Is_Ghost_Entity (Id); -- The Ghost policy in effect at the point of declaration @@ -4347,10 +4349,8 @@ package body Sem_Ch3 is -- An object declared within a Ghost region is automatically Ghost -- (SPARK RM 6.9(2)). - if Comes_From_Source (Id) - and then (Ghost_Mode > None - or else (Present (Prev_Entity) - and then Is_Ghost_Entity (Prev_Entity))) + if Ghost_Mode > None + or else (Present (Prev_Entity) and then Is_Ghost_Entity (Prev_Entity)) then Set_Is_Ghost_Entity (Id); @@ -5730,7 +5730,7 @@ package body Sem_Ch3 is -- Inherit the "ghostness" from the constrained array type - if Is_Ghost_Entity (T) or else Ghost_Mode > None then + if Ghost_Mode > None or else Is_Ghost_Entity (T) then Set_Is_Ghost_Entity (Implicit_Base); end if; @@ -6214,7 +6214,7 @@ package body Sem_Ch3 is -- Inherit the "ghostness" from the parent base type - if Is_Ghost_Entity (Parent_Base) or else Ghost_Mode > None then + if Ghost_Mode > None or else Is_Ghost_Entity (Parent_Base) then Set_Is_Ghost_Entity (Implicit_Base); end if; end Make_Implicit_Base; @@ -15815,25 +15815,23 @@ package body Sem_Ch3 is elsif Protected_Present (Iface_Def) then Error_Msg_NE - ("descendant of& must be declared" - & " as a protected interface", - N, Parent_Type); + ("descendant of & must be declared as a protected " + & "interface", N, Parent_Type); elsif Synchronized_Present (Iface_Def) then Error_Msg_NE - ("descendant of& must be declared" - & " as a synchronized interface", - N, Parent_Type); + ("descendant of & must be declared as a synchronized " + & "interface", N, Parent_Type); elsif Task_Present (Iface_Def) then Error_Msg_NE - ("descendant of& must be declared as a task interface", + ("descendant of & must be declared as a task interface", N, Parent_Type); else Error_Msg_N - ("(Ada 2005) limited interface cannot " - & "inherit from non-limited interface", Indic); + ("(Ada 2005) limited interface cannot inherit from " + & "non-limited interface", Indic); end if; -- Ada 2005 (AI-345): Non-limited interfaces can only inherit @@ -15848,19 +15846,17 @@ package body Sem_Ch3 is elsif Protected_Present (Iface_Def) then Error_Msg_NE - ("descendant of& must be declared" - & " as a protected interface", - N, Parent_Type); + ("descendant of & must be declared as a protected " + & "interface", N, Parent_Type); elsif Synchronized_Present (Iface_Def) then Error_Msg_NE - ("descendant of& must be declared" - & " as a synchronized interface", - N, Parent_Type); + ("descendant of & must be declared as a synchronized " + & "interface", N, Parent_Type); elsif Task_Present (Iface_Def) then Error_Msg_NE - ("descendant of& must be declared as a task interface", + ("descendant of & must be declared as a task interface", N, Parent_Type); else null; @@ -15874,8 +15870,8 @@ package body Sem_Ch3 is and then not Is_Interface (Parent_Type) then Error_Msg_N - ("parent type of a record extension cannot be " - & "a synchronized tagged type (RM 3.9.1 (3/1))", N); + ("parent type of a record extension cannot be a synchronized " + & "tagged type (RM 3.9.1 (3/1))", N); Set_Etype (T, Any_Type); return; end if; @@ -18240,6 +18236,12 @@ package body Sem_Ch3 is -- The class-wide type of a class-wide type is itself (RM 3.9(14)) Set_Class_Wide_Type (CW_Type, CW_Type); + + -- Inherit the "ghostness" from the root tagged type + + if Ghost_Mode > None or else Is_Ghost_Entity (T) then + Set_Is_Ghost_Entity (CW_Type); + end if; end Make_Class_Wide_Type; ---------------- diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index c03269360bf..6a3e5e7644f 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -1267,7 +1267,7 @@ package body Sem_Ch6 is -- property is not directly inherited as the body may be subject -- to a different Ghost assertion policy. - if Is_Ghost_Entity (Gen_Id) or else Ghost_Mode > None then + if Ghost_Mode > None or else Is_Ghost_Entity (Gen_Id) then Set_Is_Ghost_Entity (Body_Id); -- The Ghost policy in effect at the point of declaration and at @@ -3286,7 +3286,7 @@ package body Sem_Ch6 is -- property is not directly inherited as the body may be subject -- to a different Ghost assertion policy. - if Is_Ghost_Entity (Spec_Id) or else Ghost_Mode > None then + if Ghost_Mode > None or else Is_Ghost_Entity (Spec_Id) then Set_Is_Ghost_Entity (Body_Id); -- The Ghost policy in effect at the point of declaration and @@ -3457,6 +3457,13 @@ package body Sem_Ch6 is New_Overloaded_Entity (Body_Id); + -- A subprogram body declared within a Ghost region is automatically + -- Ghost (SPARK RM 6.9(2)). + + if Ghost_Mode > None then + Set_Is_Ghost_Entity (Body_Id); + end if; + if Nkind (N) /= N_Subprogram_Body_Stub then Set_Acts_As_Spec (N); Generate_Definition (Body_Id); @@ -4184,7 +4191,7 @@ package body Sem_Ch6 is -- A subprogram declared within a Ghost region is automatically Ghost -- (SPARK RM 6.9(2)). - if Comes_From_Source (Designator) and then Ghost_Mode > None then + if Ghost_Mode > None then Set_Is_Ghost_Entity (Designator); end if; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 70f5dfdfb79..a3870e89500 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -742,11 +742,11 @@ package body Sem_Ch7 is Set_SPARK_Aux_Pragma_Inherited (Body_Id); end if; - -- Inherit the "ghostness" of the subprogram spec. Note that this - -- property is not directly inherited as the body may be subject to a - -- different Ghost assertion policy. + -- Inherit the "ghostness" of the package spec. Note that this property + -- is not directly inherited as the body may be subject to a different + -- Ghost assertion policy. - if Is_Ghost_Entity (Spec_Id) or else Ghost_Mode > None then + if Ghost_Mode > None or else Is_Ghost_Entity (Spec_Id) then Set_Is_Ghost_Entity (Body_Id); -- The Ghost policy in effect at the point of declaration and at the diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 18023c152ae..e488ee77808 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -5644,41 +5644,61 @@ package body Sem_Ch8 is -- the scope of its declaration. procedure Find_Expanded_Name (N : Node_Id) is - function In_Pragmas_Depends_Or_Global (N : Node_Id) return Boolean; - -- Determine whether an arbitrary node N appears in pragmas [Refined_] - -- Depends or [Refined_]Global. + function In_Abstract_View_Pragma (Nod : Node_Id) return Boolean; + -- Determine whether expanded name Nod appears within a pragma which is + -- a suitable context for an abstract view of a state or variable. The + -- following pragmas fall in this category: + -- Depends + -- Global + -- Initializes + -- Refined_Depends + -- Refined_Global + -- + -- In addition, pragma Abstract_State is also considered suitable even + -- though it is an illegal context for an abstract view as this allows + -- for proper resolution of abstract views of variables. This illegal + -- context is later flagged in the analysis of indicator Part_Of. - ---------------------------------- - -- In_Pragmas_Depends_Or_Global -- - ---------------------------------- + ----------------------------- + -- In_Abstract_View_Pragma -- + ----------------------------- - function In_Pragmas_Depends_Or_Global (N : Node_Id) return Boolean is + function In_Abstract_View_Pragma (Nod : Node_Id) return Boolean is Par : Node_Id; begin -- Climb the parent chain looking for a pragma - Par := N; + Par := Nod; while Present (Par) loop - if Nkind (Par) = N_Pragma - and then Nam_In (Pragma_Name (Par), Name_Depends, - Name_Global, - Name_Refined_Depends, - Name_Refined_Global) - then - return True; + if Nkind (Par) = N_Pragma then + if Nam_In (Pragma_Name (Par), Name_Abstract_State, + Name_Depends, + Name_Global, + Name_Initializes, + Name_Refined_Depends, + Name_Refined_Global) + then + return True; + + -- Otherwise the pragma is not a legal context for an abstract + -- view. + + else + exit; + end if; -- Prevent the search from going too far elsif Is_Body_Or_Package_Declaration (Par) then - return False; + exit; end if; Par := Parent (Par); end loop; return False; - end In_Pragmas_Depends_Or_Global; + end In_Abstract_View_Pragma; -- Local variables @@ -5724,18 +5744,19 @@ package body Sem_Ch8 is Is_New_Candidate := True; -- Handle abstract views of states and variables. These are - -- acceptable only when the reference to the view appears in - -- pragmas [Refined_]Depends and [Refined_]Global. + -- acceptable candidates only when the reference to the view + -- appears in certain pragmas. if Ekind (Id) = E_Abstract_State and then From_Limited_With (Id) and then Present (Non_Limited_View (Id)) then - if In_Pragmas_Depends_Or_Global (N) then + if In_Abstract_View_Pragma (N) then Candidate := Non_Limited_View (Id); Is_New_Candidate := True; - -- Hide candidate because it is not used in a proper context + -- Hide the candidate because it is not used in a proper + -- context. else Candidate := Empty; @@ -5827,22 +5848,22 @@ package body Sem_Ch8 is Find_Expanded_Name (N); return; + -- There is an implicit instance of the predefined operator in + -- the given scope. The operator entity is defined in Standard. + -- Has_Implicit_Operator makes the node into an Expanded_Name. + elsif Nkind (Selector) = N_Operator_Symbol and then Has_Implicit_Operator (N) then - -- There is an implicit instance of the predefined operator in - -- the given scope. The operator entity is defined in Standard. - -- Has_Implicit_Operator makes the node into an Expanded_Name. - return; + -- If there is no literal defined in the scope denoted by the + -- prefix, the literal may belong to (a type derived from) + -- Standard_Character, for which we have no explicit literals. + elsif Nkind (Selector) = N_Character_Literal and then Has_Implicit_Character_Literal (N) then - -- If there is no literal defined in the scope denoted by the - -- prefix, the literal may belong to (a type derived from) - -- Standard_Character, for which we have no explicit literals. - return; else @@ -5879,8 +5900,8 @@ package body Sem_Ch8 is and then not In_Private_Part (Current_Scope) and then not Is_Private_Descendant (Current_Scope) then - Error_Msg_N ("private child unit& is not visible here", - Selector); + Error_Msg_N + ("private child unit& is not visible here", Selector); -- Normal case where we have a missing with for a child unit @@ -5929,8 +5950,9 @@ package body Sem_Ch8 is E_Package, E_Procedure) then - P := Generic_Parent (Specification - (Unit_Declaration_Node (S))); + P := + Generic_Parent (Specification + (Unit_Declaration_Node (S))); -- Check that P is a generic child of the generic -- parent of the prefix. @@ -5968,7 +5990,6 @@ package body Sem_Ch8 is -- Here we have the case of an undefined component else - -- The prefix may hide a homonym in the context that -- declares the desired entity. This error can use a -- specialized message. diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index fa00f620506..58775ac47bd 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -3413,6 +3413,19 @@ package body Sem_Prag is return; end if; + -- Catch a case where indicator Part_Of denotes the abstract view of + -- a variable which appears as an abstract state (SPARK RM 10.1.2 2). + + if From_Limited_With (State_Id) + and then Present (Non_Limited_View (State_Id)) + and then Ekind (Non_Limited_View (State_Id)) = E_Variable + then + SPARK_Msg_N + ("indicator Part_Of must denote an abstract state", State); + SPARK_Msg_N ("\& denotes abstract view of object", State); + return; + end if; + -- Determine where the state, object or the package instantiation -- lives with respect to the enclosing packages or package bodies (if -- any). This placement dictates the legality of the encapsulating @@ -11693,7 +11706,7 @@ package body Sem_Prag is Scope_Suppress.Overflow_Mode_Assertions := Eliminated; end; - -- Not that special case! + -- Not that special case else Analyze (N); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 4de4549f2b2..0a0c2897665 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -4528,7 +4528,8 @@ package body Sem_Res is -- The actual parameter of a Ghost subprogram whose formal is of -- mode IN OUT or OUT must be a Ghost variable (SPARK RM 6.9(13)). - if Is_Ghost_Entity (Nam) + if Comes_From_Source (Nam) + and then Is_Ghost_Entity (Nam) and then Ekind_In (F, E_In_Out_Parameter, E_Out_Parameter) and then Is_Entity_Name (A) and then Present (Entity (A))