From 95fef24ff9a7ed0a90781fd153e797d086aa2647 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 23 Oct 2015 12:29:50 +0200 Subject: [PATCH] [multiple changes] 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. From-SVN: r229224 --- gcc/ada/ChangeLog | 68 + gcc/ada/debug.adb | 8 +- gcc/ada/einfo.adb | 29 +- gcc/ada/einfo.ads | 14 +- gcc/ada/exp_ch13.adb | 19 +- gcc/ada/exp_ch3.adb | 4410 +++++++++++++++++++++--------------------- gcc/ada/exp_ch6.adb | 6 + gcc/ada/exp_dbug.adb | 43 +- gcc/ada/exp_dbug.ads | 11 +- gcc/ada/exp_prag.adb | 22 +- gcc/ada/exp_strm.adb | 4 +- gcc/ada/g-awk.ads | 4 +- gcc/ada/ghost.adb | 77 +- gcc/ada/ghost.ads | 4 - gcc/ada/sem_ch13.adb | 88 +- gcc/ada/sem_ch3.adb | 56 +- gcc/ada/sem_ch6.adb | 13 +- gcc/ada/sem_ch7.adb | 8 +- gcc/ada/sem_ch8.adb | 89 +- gcc/ada/sem_prag.adb | 15 +- gcc/ada/sem_res.adb | 3 +- 21 files changed, 2606 insertions(+), 2385 deletions(-) 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,2794 +4573,2826 @@ 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 - return; - end if; + Set_Ghost_Mode_From_Entity (Typ); - -- 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 not Is_Bit_Packed_Array (Typ) then - if No (Rec_Ext_Part) then - Rec_Ext_Part := - Make_Record_Definition (Loc, - End_Label => Empty, - Component_List => Empty, - Null_Present => True); + -- 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_Record_Extension_Part (Def, Rec_Ext_Part); - Mark_Rewrite_Insertion (Rec_Ext_Part); - end if; + 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)); - Comp_List := Component_List (Rec_Ext_Part); + if No (Init_Proc (Base)) then - Parent_N := Make_Defining_Identifier (Loc, Name_uParent); + -- 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 the derived type inherits its discriminants the type of the - -- _parent field must be constrained by the inherited discriminants + 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; - 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; + -- 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. - 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); + elsif Is_Standard_String_Type (Base) then + null; - -- Otherwise the original subtype_indication is just what is needed + -- Otherwise we have to build an init proc for the subtype - else - Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def); - end if; + else + Build_Array_Init_Proc (Base, N); + end if; + end if; - Set_Parent_Subtype (T, Par_Subtype); + if Typ = Base then + if Has_Controlled_Component (Base) then + Build_Controlling_Procs (Base); - 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 not Is_Limited_Type (Comp_Typ) + and then Number_Dimensions (Typ) = 1 + then + Build_Slice_Assignment (Typ); + end if; + end if; - 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); + -- Create a finalization master to service the anonymous access + -- components of the array. - 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); + 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. - else - Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); - end if; + if Is_Itype (Typ) then + Ins_Node := Associated_Node_For_Itype (Typ); + else + Ins_Node := Parent (Typ); + end if; - Analyze (Comp_Decl); - end Expand_Record_Extension; + Build_Finalization_Master + (Typ => Comp_Typ, + For_Anonymous => True, + Context_Scope => Scope (Typ), + Insertion_Node => Ins_Node); + end if; + end if; - ------------------------------------ - -- Expand_N_Full_Type_Declaration -- - ------------------------------------ + -- 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. - procedure Expand_N_Full_Type_Declaration (N : Node_Id) is - procedure Build_Master (Ptr_Typ : Entity_Id); - -- Create the master associated with Ptr_Typ + 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; - ------------------ - -- Build_Master -- - ------------------ + 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. - procedure Build_Master (Ptr_Typ : Entity_Id) is - Desig_Typ : Entity_Id := Designated_Type (Ptr_Typ); + Insert_Component_Invariant_Checks + (N, Base, Build_Array_Invariant_Proc (Base, N)); + end if; - begin - -- If the designated type is an incomplete view coming from a - -- limited-with'ed package, we need to use the nonlimited view in - -- case it has tasks. + Ghost_Mode := Save_Ghost_Mode; + end Expand_Freeze_Array_Type; - if Ekind (Desig_Typ) in Incomplete_Kind - and then Present (Non_Limited_View (Desig_Typ)) - then - Desig_Typ := Non_Limited_View (Desig_Typ); - end if; + ----------------------------------- + -- Expand_Freeze_Class_Wide_Type -- + ----------------------------------- - -- Anonymous access types are created for the components of the - -- record parameter for an entry declaration. No master is created - -- for such a 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 - if Comes_From_Source (N) and then Has_Task (Desig_Typ) then - Build_Master_Entity (Ptr_Typ); - Build_Master_Renaming (Ptr_Typ); + --------------------- + -- Is_C_Derivation -- + --------------------- - -- Create a class-wide master because a Master_Id must be generated - -- for access-to-limited-class-wide types whose root may be extended - -- with task components. + function Is_C_Derivation (Typ : Entity_Id) return Boolean is + T : Entity_Id; - -- Note: This code covers access-to-limited-interfaces because they - -- can be used to reference tasks implementing them. + 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; - elsif Is_Limited_Class_Wide_Type (Desig_Typ) - and then Tasking_Allowed - then - Build_Class_Wide_Master (Ptr_Typ); - end if; - end Build_Master; + exit when T = Etype (T); - -- Local declarations + T := Etype (T); + end loop; - Def_Id : constant Entity_Id := Defining_Identifier (N); - B_Id : constant Entity_Id := Base_Type (Def_Id); - FN : Node_Id; - Par_Id : Entity_Id; + return False; + end Is_C_Derivation; - -- Start of processing for Expand_N_Full_Type_Declaration + -- Local variables - begin - if Is_Access_Type (Def_Id) then - Build_Master (Def_Id); + Typ : constant Entity_Id := Entity (N); + Root : constant Entity_Id := Root_Type (Typ); - if Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then - Expand_Access_Protected_Subprogram_Type (N); - end if; + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; - -- Array of anonymous access-to-task pointers + -- Start of processing for Expand_Freeze_Class_Wide_Type - elsif Ada_Version >= Ada_2005 - and then Is_Array_Type (Def_Id) - and then Is_Access_Type (Component_Type (Def_Id)) - and then Ekind (Component_Type (Def_Id)) = E_Anonymous_Access_Type - then - Build_Master (Component_Type (Def_Id)); + begin + -- Certain run-time configurations and targets do not provide support + -- for controlled types. - elsif Has_Task (Def_Id) then - Expand_Previous_Access_Type (Def_Id); + if Restriction_Active (No_Finalization) then + return; - -- Check the components of a record type or array of records for - -- anonymous access-to-task pointers. + -- Do not create TSS routine Finalize_Address when dispatching calls are + -- disabled since the core of the routine is a dispatching call. - elsif Ada_Version >= Ada_2005 - and then (Is_Record_Type (Def_Id) - or else - (Is_Array_Type (Def_Id) - and then Is_Record_Type (Component_Type (Def_Id)))) - then - declare - Comp : Entity_Id; - First : Boolean; - M_Id : Entity_Id; - Typ : Entity_Id; + elsif Restriction_Active (No_Dispatching_Calls) then + return; - begin - if Is_Array_Type (Def_Id) then - Comp := First_Entity (Component_Type (Def_Id)); - else - Comp := First_Entity (Def_Id); - end if; + -- 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. - -- Examine all components looking for anonymous access-to-task - -- types. + elsif Is_Concurrent_Type (Root) + or else Is_C_Derivation (Root) + or else Convention (Typ) = Convention_CPP + then + return; - First := True; - while Present (Comp) loop - Typ := Etype (Comp); + -- Do not create TSS routine Finalize_Address when compiling in CodePeer + -- mode since the routine contains an Unchecked_Conversion. - if Ekind (Typ) = E_Anonymous_Access_Type - and then Has_Task (Available_View (Designated_Type (Typ))) - and then No (Master_Id (Typ)) - then - -- Ensure that the record or array type have a _master + elsif CodePeer_Mode then + return; + end if; - if First then - Build_Master_Entity (Def_Id); - Build_Master_Renaming (Typ); - M_Id := Master_Id (Typ); + -- Ensure that all freezing activities are properly flagged as Ghost - First := False; + Set_Ghost_Mode_From_Entity (Typ); - -- Reuse the same master to service any additional types + -- Create the body of TSS primitive Finalize_Address. This automatically + -- sets the TSS entry for the class-wide type. - else - Set_Master_Id (Typ, M_Id); - end if; - end if; + Make_Finalize_Address_Body (Typ); + Ghost_Mode := Save_Ghost_Mode; + end Expand_Freeze_Class_Wide_Type; - Next_Entity (Comp); - end loop; - end; - end if; + ------------------------------------ + -- Expand_Freeze_Enumeration_Type -- + ------------------------------------ - Par_Id := Etype (B_Id); + procedure Expand_Freeze_Enumeration_Type (N : Node_Id) is + Typ : constant Entity_Id := Entity (N); + Loc : constant Source_Ptr := Sloc (Typ); - -- The parent type is private then we need to inherit any TSS operations - -- from the full view. + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; - if Ekind (Par_Id) in Private_Kind - and then Present (Full_View (Par_Id)) - then - Par_Id := Base_Type (Full_View (Par_Id)); - end if; + 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; - if Nkind (Type_Definition (Original_Node (N))) = - N_Derived_Type_Definition - and then not Is_Tagged_Type (Def_Id) - and then Present (Freeze_Node (Par_Id)) - and then Present (TSS_Elist (Freeze_Node (Par_Id))) - then - Ensure_Freeze_Node (B_Id); - FN := Freeze_Node (B_Id); + Func : Entity_Id; + pragma Warnings (Off, Func); - if No (TSS_Elist (FN)) then - Set_TSS_Elist (FN, New_Elmt_List); - end if; + begin + -- Ensure that all freezing activities are properly flagged as Ghost - declare - T_E : constant Elist_Id := TSS_Elist (FN); - Elmt : Elmt_Id; + Set_Ghost_Mode_From_Entity (Typ); - begin - Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id))); - while Present (Elmt) loop - if Chars (Node (Elmt)) /= Name_uInit then - Append_Elmt (Node (Elmt), T_E); - end if; + -- Various optimizations possible if given representation is contiguous - Next_Elmt (Elmt); - end loop; + Is_Contiguous := True; - -- If the derived type itself is private with a full view, then - -- associate the full view with the inherited TSS_Elist as well. + Ent := First_Literal (Typ); + Last_Repval := Enumeration_Rep (Ent); - if Ekind (B_Id) in Private_Kind - and then Present (Full_View (B_Id)) - then - Ensure_Freeze_Node (Base_Type (Full_View (B_Id))); - Set_TSS_Elist - (Freeze_Node (Base_Type (Full_View (B_Id))), TSS_Elist (FN)); - end if; - end; - end if; - end Expand_N_Full_Type_Declaration; + 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; - --------------------------------- - -- Expand_N_Object_Declaration -- - --------------------------------- + Next_Literal (Ent); + end loop; - procedure Expand_N_Object_Declaration (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Def_Id : constant Entity_Id := Defining_Identifier (N); - Expr : constant Node_Id := Expression (N); - Obj_Def : constant Node_Id := Object_Definition (N); - Typ : constant Entity_Id := Etype (Def_Id); - Base_Typ : constant Entity_Id := Base_Type (Typ); - Expr_Q : Node_Id; + if Is_Contiguous then + Set_Has_Contiguous_Rep (Typ); + Ent := First_Literal (Typ); + Num := 1; + Lst := New_List (New_Occurrence_Of (Ent, Sloc (Ent))); - function Build_Equivalent_Aggregate return Boolean; - -- If the object has a constrained discriminated type and no initial - -- value, it may be possible to build an equivalent aggregate instead, - -- and prevent an actual call to the initialization procedure. + else + -- Build list of literal references - procedure Default_Initialize_Object (After : Node_Id); - -- Generate all default initialization actions for object Def_Id. Any - -- new code is inserted after node After. + Lst := New_List; + Num := 0; - function Rewrite_As_Renaming return Boolean; - -- Indicate whether to rewrite a declaration with initialization into an - -- object renaming declaration (see below). + 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; - -------------------------------- - -- Build_Equivalent_Aggregate -- - -------------------------------- + -- Now build an array declaration - function Build_Equivalent_Aggregate return Boolean is - Aggr : Node_Id; - Comp : Entity_Id; - Discr : Elmt_Id; - Full_Type : Entity_Id; + -- typA : array (Natural range 0 .. num - 1) of ctype := + -- (v, v, v, v, v, ....) - begin - Full_Type := Typ; + -- 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. - if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then - Full_Type := Full_View (Typ); - end if; + Arr := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), 'A')); - -- Only perform this transformation if Elaboration_Code is forbidden - -- or undesirable, and if this is a global entity of a constrained - -- record type. - - -- If Initialize_Scalars might be active this transformation cannot - -- be performed either, because it will lead to different semantics - -- or because elaboration code will in fact be created. - - if Ekind (Full_Type) /= E_Record_Subtype - or else not Has_Discriminants (Full_Type) - or else not Is_Constrained (Full_Type) - or else Is_Controlled (Full_Type) - or else Is_Limited_Type (Full_Type) - or else not Restriction_Active (No_Initialize_Scalars) - then - return False; - end if; - - if Ekind (Current_Scope) = E_Package - and then - (Restriction_Active (No_Elaboration_Code) - or else Is_Preelaborated (Current_Scope)) - then - -- Building a static aggregate is possible if the discriminants - -- have static values and the other components have static - -- defaults or none. - - Discr := First_Elmt (Discriminant_Constraint (Full_Type)); - while Present (Discr) loop - if not Is_OK_Static_Expression (Node (Discr)) then - return False; - end if; + Append_Freeze_Action (Typ, + Make_Object_Declaration (Loc, + Defining_Identifier => Arr, + Constant_Present => True, - Next_Elmt (Discr); - end loop; + 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))))), - -- Check that initialized components are OK, and that non- - -- initialized components do not require a call to their own - -- initialization procedure. + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => New_Occurrence_Of (Typ, Loc))), - Comp := First_Component (Full_Type); - while Present (Comp) loop - if Ekind (Comp) = E_Component - and then Present (Expression (Parent (Comp))) - and then - not Is_OK_Static_Expression (Expression (Parent (Comp))) - then - return False; + Expression => + Make_Aggregate (Loc, + Expressions => Lst))); - elsif Has_Non_Null_Base_Init_Proc (Etype (Comp)) then - return False; + Set_Enum_Pos_To_Rep (Typ, Arr); - end if; + -- Now we build the function that converts representation values to + -- position values. This function has the form: - Next_Component (Comp); - end loop; + -- 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; - -- Everything is static, assemble the aggregate, discriminant - -- values first. + -- 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. - Aggr := - Make_Aggregate (Loc, - Expressions => New_List, - Component_Associations => New_List); + -- 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. - Discr := First_Elmt (Discriminant_Constraint (Full_Type)); - while Present (Discr) loop - Append_To (Expressions (Aggr), New_Copy (Node (Discr))); - Next_Elmt (Discr); - end loop; + -- 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. - -- Now collect values of initialized components + -- Is this right??? What about No_Exception_Propagation??? - Comp := First_Component (Full_Type); - while Present (Comp) loop - if Ekind (Comp) = E_Component - and then Present (Expression (Parent (Comp))) - then - Append_To (Component_Associations (Aggr), - Make_Component_Association (Loc, - Choices => New_List (New_Occurrence_Of (Comp, Loc)), - Expression => New_Copy_Tree - (Expression (Parent (Comp))))); - end if; + -- Representations are signed - Next_Component (Comp); - end loop; + if Enumeration_Rep (First_Literal (Typ)) < 0 then - -- Finally, box-initialize remaining components + -- The underlying type is signed. Reset the Is_Unsigned_Type + -- explicitly, because it might have been inherited from + -- parent type. - Append_To (Component_Associations (Aggr), - Make_Component_Association (Loc, - Choices => New_List (Make_Others_Choice (Loc)), - Expression => Empty)); - Set_Box_Present (Last (Component_Associations (Aggr))); - Set_Expression (N, Aggr); + Set_Is_Unsigned_Type (Typ, False); - if Typ /= Full_Type then - Analyze_And_Resolve (Aggr, Full_View (Base_Type (Full_Type))); - Rewrite (Aggr, Unchecked_Convert_To (Typ, Aggr)); - Analyze_And_Resolve (Aggr, Typ); - else - Analyze_And_Resolve (Aggr, Full_Type); - end if; + if Esize (Typ) <= Standard_Integer_Size then + Ityp := Standard_Integer; + else + Ityp := Universal_Integer; + end if; - return True; + -- Representations are unsigned + else + if Esize (Typ) <= Standard_Integer_Size then + Ityp := RTE (RE_Unsigned); else - return False; + Ityp := RTE (RE_Long_Long_Unsigned); end if; - end Build_Equivalent_Aggregate; - - ------------------------------- - -- Default_Initialize_Object -- - ------------------------------- + end if; - procedure Default_Initialize_Object (After : Node_Id) is - function New_Object_Reference return Node_Id; - -- Return a new reference to Def_Id with attributes Assignment_OK and - -- Must_Not_Freeze already set. + -- The body of the function is a case statement. First collect case + -- alternatives, or optimize the contiguous case. - -------------------------- - -- New_Object_Reference -- - -------------------------- + Lst := New_List; - function New_Object_Reference return Node_Id is - Obj_Ref : constant Node_Id := New_Occurrence_Of (Def_Id, Loc); + -- If representation is contiguous, Pos is computed by subtracting + -- the representation of the first literal. - begin - -- The call to the type init proc or [Deep_]Finalize must not - -- freeze the related object as the call is internally generated. - -- This way legal rep clauses that apply to the object will not be - -- flagged. Note that the initialization call may be removed if - -- pragma Import is encountered or moved to the freeze actions of - -- the object because of an address clause. + if Is_Contiguous then + Ent := First_Literal (Typ); - Set_Assignment_OK (Obj_Ref); - Set_Must_Not_Freeze (Obj_Ref); + if Enumeration_Rep (Ent) = Last_Repval then - return Obj_Ref; - end New_Object_Reference; + -- Another special case: for a single literal, Pos is zero - -- Local variables + Pos_Expr := Make_Integer_Literal (Loc, Uint_0); - Abrt_Blk : Node_Id; - Abrt_HSS : Node_Id; - Abrt_Id : Entity_Id; - Abrt_Stmts : List_Id; - Aggr_Init : Node_Id; - Comp_Init : List_Id := No_List; - Fin_Call : Node_Id; - Fin_Stmts : List_Id := No_List; - Obj_Init : Node_Id := Empty; - Obj_Ref : Node_Id; + 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; - Dummy : Entity_Id; - -- This variable captures a dummy internal entity, see the comment - -- associated with its use. + 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))), - -- Start of processing for Default_Initialize_Object + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => Pos_Expr)))); - begin - -- Default initialization is suppressed for objects that are already - -- known to be imported (i.e. whose declaration specifies the Import - -- aspect). Note that for objects with a pragma Import, we generate - -- initialization here, and then remove it downstream when processing - -- the pragma. It is also suppressed for variables for which a pragma - -- Suppress_Initialization has been explicitly given + 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))), - if Is_Imported (Def_Id) or else Suppress_Initialization (Def_Id) then - return; - end if; + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + Make_Integer_Literal (Loc, + Intval => Enumeration_Pos (Ent)))))); - -- Step 1: Initialize the object + Next_Literal (Ent); + end loop; + end if; - if Needs_Finalization (Typ) and then not No_Initialization (N) then - Obj_Init := - Make_Init_Call - (Obj_Ref => New_Occurrence_Of (Def_Id, Loc), - Typ => Typ); - end if; + -- In normal mode, add the others clause with the test - -- Step 2: Initialize the components of the object - - -- Do not initialize the components if their initialization is - -- prohibited. + 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 Has_Non_Null_Base_Init_Proc (Typ) - and then not No_Initialization (N) - and then not Initialization_Suppressed (Typ) - then - -- Do not initialize the components if No_Default_Initialization - -- applies as the actual restriction check will occur later - -- when the object is frozen as it is not known yet whether the - -- object is imported or not. + -- 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. - if not Restriction_Active (No_Default_Initialization) then + 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; - -- If the values of the components are compile-time known, use - -- their prebuilt aggregate form directly. + -- Now we can build the function body - Aggr_Init := Static_Initialization (Base_Init_Proc (Typ)); + Fent := + Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos)); - if Present (Aggr_Init) then - Set_Expression - (N, New_Copy_Tree (Aggr_Init, New_Scope => Current_Scope)); + 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))), - -- If type has discriminants, try to build an equivalent - -- aggregate using discriminant values from the declaration. - -- This is a useful optimization, in particular if restriction - -- No_Elaboration_Code is active. + Result_Definition => New_Occurrence_Of (Standard_Integer, Loc)), - elsif Build_Equivalent_Aggregate then - null; + Declarations => Empty_List, - -- Otherwise invoke the type init proc + 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)))); - else - Obj_Ref := New_Object_Reference; + Set_TSS (Typ, Fent); - if Comes_From_Source (Def_Id) then - Initialization_Warning (Obj_Ref); - end if; + -- 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). - Comp_Init := Build_Initialization_Call (Loc, Obj_Ref, Typ); - end if; - end if; + Set_Is_Pure (Fent); + Set_Has_Pragma_Pure_Function (Fent); - -- Provide a default value if the object needs simple initialization - -- and does not already have an initial value. A generated temporary - -- does not require initialization because it will be assigned later. + -- 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. - elsif Needs_Simple_Initialization - (Typ, Initialize_Scalars - and then No (Following_Address_Clause (N))) - and then not Is_Internal (Def_Id) - and then not Has_Init_Expression (N) - then - Set_No_Initialization (N, False); - Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id))); - Analyze_And_Resolve (Expression (N), Typ); - end if; + if not Debug_Generated_Code then + Set_Debug_Info_Off (Fent); + end if; - -- Step 3: Add partial finalization and abort actions, generate: + Ghost_Mode := Save_Ghost_Mode; - -- Type_Init_Proc (Obj); - -- begin - -- Deep_Initialize (Obj); - -- exception - -- when others => - -- Deep_Finalize (Obj, Self => False); - -- raise; - -- end; + exception + when RE_Not_Available => + Ghost_Mode := Save_Ghost_Mode; + return; + end Expand_Freeze_Enumeration_Type; - -- Step 3a: Build the finalization block (if applicable) + ------------------------------- + -- Expand_Freeze_Record_Type -- + ------------------------------- - -- The finalization block is required when both the object and its - -- controlled components are to be initialized. The block finalizes - -- the components if the object initialization fails. + procedure Expand_Freeze_Record_Type (N : Node_Id) is + Typ : constant Node_Id := Entity (N); + Typ_Decl : constant Node_Id := Parent (Typ); - if Has_Controlled_Component (Typ) - and then Present (Comp_Init) - and then Present (Obj_Init) - and then not Restriction_Active (No_Exception_Propagation) - then - -- Generate: - -- Type_Init_Proc (Obj); + Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; - Fin_Stmts := Comp_Init; + Comp : Entity_Id; + Comp_Typ : Entity_Id; + Has_AACC : Boolean; + Predef_List : List_Id; - -- Generate: - -- begin - -- Deep_Initialize (Obj); - -- exception - -- when others => - -- Deep_Finalize (Obj, Self => False); - -- raise; - -- end; + 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. - Fin_Call := - Make_Final_Call - (Obj_Ref => New_Object_Reference, - Typ => Typ, - Skip_Self => True); + Wrapper_Decl_List : List_Id := No_List; + Wrapper_Body_List : List_Id := No_List; - if Present (Fin_Call) then + -- Start of processing for Expand_Freeze_Record_Type - -- Do not emit warnings related to the elaboration order when a - -- controlled object is declared before the body of Finalize is - -- seen. + begin + -- Ensure that all freezing activities are properly flagged as Ghost - Set_No_Elaboration_Check (Fin_Call); + Set_Ghost_Mode_From_Entity (Typ); - Append_To (Fin_Stmts, - Make_Block_Statement (Loc, - Declarations => No_List, + -- 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. - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Obj_Init), + if not Is_Derived_Type (Typ) + or else Has_New_Non_Standard_Rep (Typ) + or else Is_Tagged_Type (Typ) + then + Build_Discr_Checking_Funcs (Typ_Decl); - Exception_Handlers => New_List ( - Make_Exception_Handler (Loc, - Exception_Choices => New_List ( - Make_Others_Choice (Loc)), + elsif Is_Derived_Type (Typ) + and then not Is_Tagged_Type (Typ) - Statements => New_List ( - Fin_Call, - Make_Raise_Statement (Loc))))))); - end if; + -- 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. - -- Finalization is not required, the initialization calls are passed - -- to the abort block building circuitry, generate: + and then not Is_Unchecked_Union (Typ) + and then Has_Discriminants (Typ) + then + declare + Old_Comp : Entity_Id; - -- Type_Init_Proc (Obj); - -- Deep_Initialize (Obj); + 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; - else - if Present (Comp_Init) then - Fin_Stmts := Comp_Init; - end if; + Next_Component (Old_Comp); + Next_Component (Comp); + end loop; + end; + end if; - if Present (Obj_Init) then - if No (Fin_Stmts) then - Fin_Stmts := New_List; - end if; + if Is_Derived_Type (Typ) + and then Is_Limited_Type (Typ) + and then Is_Tagged_Type (Typ) + then + Check_Stream_Attributes (Typ); + end if; - Append_To (Fin_Stmts, Obj_Init); - end if; - 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. - -- Step 3b: Build the abort block (if applicable) + Has_AACC := False; - -- The abort block is required when aborts are allowed in order to - -- protect both initialization calls. + Comp := First_Component (Typ); + while Present (Comp) loop + Comp_Typ := Etype (Comp); - if Present (Comp_Init) and then Present (Obj_Init) then - if Abort_Allowed then + if Has_Task (Comp_Typ) then + Set_Has_Task (Typ); + end if; - -- Generate: - -- Abort_Defer; + if Has_Protected (Comp_Typ) then + Set_Has_Protected (Typ); + end if; - Prepend_To - (Fin_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); + -- Do not set Has_Controlled_Component on a class-wide equivalent + -- type. See Make_CW_Equivalent_Type. - -- Generate: - -- begin - -- Abort_Defer; - -- - -- at end - -- Abort_Undefer_Direct; - -- end; + 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; - declare - AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct); + -- Non-self-referential anonymous access-to-controlled component - begin - Abrt_HSS := - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Fin_Stmts, - At_End_Proc => New_Occurrence_Of (AUD, Loc)); + 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; - -- Present the Abort_Undefer_Direct function to the backend - -- so that it can inline the call to the function. + Next_Component (Comp); + end loop; - Add_Inlined_Body (AUD, N); - end; + -- Handle constructors of untagged CPP_Class types - Abrt_Blk := - Make_Block_Statement (Loc, - Declarations => No_List, - Handled_Statement_Sequence => Abrt_HSS); + if not Is_Tagged_Type (Typ) and then Is_CPP_Class (Typ) then + Set_CPP_Constructors (Typ); + end if; - Add_Block_Identifier (Abrt_Blk, Abrt_Id); - Expand_At_End_Handler (Abrt_HSS, Abrt_Id); + -- 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. - Abrt_Stmts := New_List (Abrt_Blk); + if Is_Tagged_Type (Typ) then - -- Abort is not required + -- Add the _Tag component - else - -- Generate a dummy entity to ensure that the internal symbols - -- are in sync when a unit is compiled with and without aborts. - -- The entity is a block with proper scope and type. + if Underlying_Type (Etype (Typ)) = Typ then + Expand_Tagged_Root (Typ); + end if; - Dummy := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); - Set_Etype (Dummy, Standard_Void_Type); - Abrt_Stmts := Fin_Stmts; - end if; + if Is_CPP_Class (Typ) then + Set_All_DT_Position (Typ); - -- No initialization calls present + -- Create the tag entities with a minimum decoration - else - Abrt_Stmts := Fin_Stmts; - end if; + if Tagged_Type_Expansion then + Append_Freeze_Actions (Typ, Make_Tags (Typ)); + end if; - -- Step 4: Insert the whole initialization sequence into the tree - -- If the object has a delayed freeze, as will be the case when - -- it has aspect specifications, the initialization sequence is - -- part of the freeze actions. + Set_CPP_Constructors (Typ); - if Has_Delayed_Freeze (Def_Id) then - Append_Freeze_Actions (Def_Id, Abrt_Stmts); else - Insert_Actions_After (After, Abrt_Stmts); - end if; - end Default_Initialize_Object; + if not Building_Static_DT (Typ) then - ------------------------- - -- Rewrite_As_Renaming -- - ------------------------- - - function Rewrite_As_Renaming return Boolean is - begin - return not Aliased_Present (N) - and then Is_Entity_Name (Expr_Q) - and then Ekind (Entity (Expr_Q)) = E_Variable - and then OK_To_Rename (Entity (Expr_Q)) - and then Is_Entity_Name (Obj_Def); - end Rewrite_As_Renaming; + -- 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. - -- Local variables + -- 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. - Next_N : constant Node_Id := Next (N); - Id_Ref : Node_Id; - Tag_Assign : Node_Id; + declare + Elmt : Elmt_Id; + Subp : Entity_Id; - Init_After : Node_Id := N; - -- Node after which the initialization actions are to be inserted. This - -- is normally N, except for the case of a shared passive variable, in - -- which case the init proc call must be inserted only after the bodies - -- of the shared variable procedures have been seen. + begin + Elmt := First_Elmt (Primitive_Operations (Typ)); + while Present (Elmt) loop + Subp := Node (Elmt); - -- Start of processing for Expand_N_Object_Declaration + if Present (Alias (Subp)) then + if Is_CPP_Class (Etype (Typ)) then + Set_Has_Delayed_Freeze (Subp); - begin - -- Don't do anything for deferred constants. All proper actions will be - -- expanded during the full declaration. + 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; - if No (Expr) and Constant_Present (N) then - return; - end if; + Next_Elmt (Elmt); + end loop; + end; + end if; - -- The type of the object cannot be abstract. This is diagnosed at the - -- point the object is frozen, which happens after the declaration is - -- fully expanded, so simply return now. + -- 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). - if Is_Abstract_Type (Typ) then - return; - end if; + Set_Is_Frozen (Typ, False); - -- First we do special processing for objects of a tagged type where - -- this is the point at which the type is frozen. The creation of the - -- dispatch table and the initialization procedure have to be deferred - -- to this point, since we reference previously declared primitive - -- subprograms. + -- Do not add the spec of predefined primitives in case of + -- CPP tagged type derivations that have convention CPP. - -- Force construction of dispatch tables of library level tagged types + if Is_CPP_Class (Root_Type (Typ)) + and then Convention (Typ) = Convention_CPP + then + null; - if Tagged_Type_Expansion - and then Static_Dispatch_Tables - and then Is_Library_Level_Entity (Def_Id) - and then Is_Library_Level_Tagged_Type (Base_Typ) - and then Ekind_In (Base_Typ, E_Record_Type, - E_Protected_Type, - E_Task_Type) - and then not Has_Dispatch_Table (Base_Typ) - then - declare - New_Nodes : List_Id := No_List; + -- Do not add the spec of the predefined primitives if we are + -- compiling under restriction No_Dispatching_Calls. - begin - if Is_Concurrent_Type (Base_Typ) then - New_Nodes := Make_DT (Corresponding_Record_Type (Base_Typ), N); - else - New_Nodes := Make_DT (Base_Typ, N); + 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; - if not Is_Empty_List (New_Nodes) then - Insert_List_Before (N, New_Nodes); + -- 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; - end; - end if; - -- Make shared memory routines for shared passive variable + -- 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 Is_Shared_Passive (Def_Id) then - Init_After := Make_Shared_Var_Procs (N); - end if; + 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; - -- If tasks being declared, make sure we have an activation chain - -- defined for the tasks (has no effect if we already have one), and - -- also that a Master variable is established and that the appropriate - -- enclosing construct is established as a task master. + Set_Is_Frozen (Typ); - if Has_Task (Typ) then - Build_Activation_Chain_Entity (N); - Build_Master_Entity (Def_Id); - end if; + if not Is_Derived_Type (Typ) + or else Is_Tagged_Type (Etype (Typ)) + then + Set_All_DT_Position (Typ); - -- Default initialization required, and no expression present + -- 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. - if No (Expr) then + elsif Is_Derived_Type (Typ) + and then Is_Private_Type (Etype (Typ)) + and then not Is_Tagged_Type (Etype (Typ)) + then + return; + end if; - -- If we have a type with a variant part, the initialization proc - -- will contain implicit tests of the discriminant values, which - -- counts as a violation of the restriction No_Implicit_Conditionals. + -- 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 Has_Variant_Part (Typ) then - declare - Msg : Boolean; + if Tagged_Type_Expansion then + Append_Freeze_Actions (Typ, Make_Tags (Typ)); - begin - Check_Restriction (Msg, No_Implicit_Conditionals, Obj_Def); + -- Generate dispatch table of locally defined tagged type. + -- Dispatch tables of library level tagged types are built + -- later (see Analyze_Declarations). - if Msg then - Error_Msg_N - ("\initialization of variant record tests discriminants", - Obj_Def); - return; + if not Building_Static_DT (Typ) then + Append_Freeze_Actions (Typ, Make_DT (Typ)); end if; - end; - end if; - - -- For the default initialization case, if we have a private type - -- with invariants, and invariant checks are enabled, then insert an - -- invariant check after the object declaration. Note that it is OK - -- to clobber the object with an invalid value since if the exception - -- is raised, then the object will go out of scope. In the case where - -- an array object is initialized with an aggregate, the expression - -- is removed. Check flag Has_Init_Expression to avoid generating a - -- junk invariant check and flag No_Initialization to avoid checking - -- an uninitialized object such as a compiler temporary used for an - -- aggregate. + end if; - if Has_Invariants (Base_Typ) - and then Present (Invariant_Procedure (Base_Typ)) - and then not Has_Init_Expression (N) - and then not No_Initialization (N) - then - -- If entity has an address clause or aspect, make invariant - -- call into a freeze action for the explicit freeze node for - -- object. Otherwise insert invariant check after declaration. + -- If the type has unknown discriminants, propagate dispatching + -- information to its underlying record view, which does not get + -- its own dispatch table. - if Present (Following_Address_Clause (N)) - or else Has_Aspect (Def_Id, Aspect_Address) + if Is_Derived_Type (Typ) + and then Has_Unknown_Discriminants (Typ) + and then Present (Underlying_Record_View (Typ)) then - Ensure_Freeze_Node (Def_Id); - Set_Has_Delayed_Freeze (Def_Id); - Set_Is_Frozen (Def_Id, False); + 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; - if not Partial_View_Has_Unknown_Discr (Typ) then - Append_Freeze_Action (Def_Id, - Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc))); + -- 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; - elsif not Partial_View_Has_Unknown_Discr (Typ) then - Insert_After (N, - Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc))); + 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; - Default_Initialize_Object (Init_After); + -- 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. - -- Generate attribute for Persistent_BSS if needed + 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; - if Persistent_BSS_Mode - and then Comes_From_Source (N) - and then Is_Potentially_Persistent_Type (Typ) - and then not Has_Init_Expression (N) - and then Is_Library_Level_Entity (Def_Id) - then - declare - Prag : Node_Id; - begin - Prag := - Make_Linker_Section_Pragma - (Def_Id, Sloc (N), ".persistent.bss"); - Insert_After (N, Prag); - Analyze (Prag); - end; - end if; + -- Otherwise create primitive equality operation (AI05-0123) - -- If access type, then we know it is null if not initialized + -- 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). - if Is_Access_Type (Typ) then - Set_Is_Known_Null (Def_Id); - end if; + 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; - -- Explicit initialization present + -- 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. - else - -- Obtain actual expression from qualified expression + 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; - if Nkind (Expr) = N_Qualified_Expression then - Expr_Q := Expression (Expr); - else - Expr_Q := Expr; - end if; + 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); - -- When we have the appropriate type of aggregate in the expression - -- (it has been determined during analysis of the aggregate by - -- setting the delay flag), let's perform in place assignment and - -- thus avoid creating a temporary. + Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr); + Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr); - if Is_Delayed_Aggregate (Expr_Q) then - Convert_Aggr_In_Object_Decl (N); + Next_Discriminant (Conc_Discr); + Next_Discriminant (Rec_Discr); + end loop; + end; + end if; - -- Ada 2005 (AI-318-02): If the initialization expression is a call - -- to a build-in-place function, then access to the declared object - -- must be passed to the function. Currently we limit such functions - -- to those with constrained limited result subtypes, but eventually - -- plan to expand the allowed forms of functions that are treated as - -- build-in-place. + if Has_Controlled_Component (Typ) then + Build_Controlling_Procs (Typ); + end if; - elsif Ada_Version >= Ada_2005 - and then Is_Build_In_Place_Function_Call (Expr_Q) - then - Make_Build_In_Place_Call_In_Object_Declaration (N, Expr_Q); + Adjust_Discriminants (Typ); - -- The previous call expands the expression initializing the - -- built-in-place object into further code that will be analyzed - -- later. No further expansion needed here. + -- Do not need init for interfaces on virtual targets since they're + -- abstract. - return; + if Tagged_Type_Expansion or else not Is_Interface (Typ) then + Build_Record_Init_Proc (Typ_Decl, Typ); + end if; - -- Ada 2005 (AI-251): Rewrite the expression that initializes a - -- class-wide interface object to ensure that we copy the full - -- object, unless we are targetting a VM where interfaces are handled - -- by VM itself. Note that if the root type of Typ is an ancestor of - -- Expr's type, both types share the same dispatch table and there is - -- no need to displace the pointer. + -- 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. - elsif Is_Interface (Typ) + if Is_Tagged_Type (Typ) and then not Is_Interface (Typ) then - -- Avoid never-ending recursion because if Equivalent_Type is set - -- then we've done it already and must not do it again. + -- Do not add the body of predefined primitives in case of CPP tagged + -- type derivations that have convention CPP. - and then not - (Nkind (Obj_Def) = N_Identifier - and then Present (Equivalent_Type (Entity (Obj_Def)))) + if Is_CPP_Class (Root_Type (Typ)) + and then Convention (Typ) = Convention_CPP then - pragma Assert (Is_Class_Wide_Type (Typ)); + null; - -- If the object is a return object of an inherently limited type, - -- which implies build-in-place treatment, bypass the special - -- treatment of class-wide interface initialization below. In this - -- case, the expansion of the return statement will take care of - -- creating the object (via allocator) and initializing it. + -- 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. - if Is_Return_Object (Def_Id) and then Is_Limited_View (Typ) then - null; + elsif not Restriction_Active (No_Dispatching_Calls) then - elsif Tagged_Type_Expansion then - declare - Iface : constant Entity_Id := Root_Type (Typ); - Expr_N : Node_Id := Expr; - Expr_Typ : Entity_Id; - New_Expr : Node_Id; - Obj_Id : Entity_Id; - Tag_Comp : Node_Id; + -- 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. - begin - -- If the original node of the expression was a conversion - -- to this specific class-wide interface type then restore - -- the original node because we must copy the object before - -- displacing the pointer to reference the secondary tag - -- component. This code must be kept synchronized with the - -- expansion done by routine Expand_Interface_Conversion + Make_Finalize_Address_Body (Typ); + Predef_List := Predefined_Primitive_Bodies (Typ, Renamed_Eq); + Append_Freeze_Actions (Typ, Predef_List); + end if; - if not Comes_From_Source (Expr_N) - and then Nkind (Expr_N) = N_Explicit_Dereference - and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion - and then Etype (Original_Node (Expr_N)) = Typ - then - Rewrite (Expr_N, Original_Node (Expression (N))); - end if; + -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden + -- inherited functions, then add their bodies to the freeze actions. - -- Avoid expansion of redundant interface conversion + if Present (Wrapper_Body_List) then + Append_Freeze_Actions (Typ, Wrapper_Body_List); + end if; - if Is_Interface (Etype (Expr_N)) - and then Nkind (Expr_N) = N_Type_Conversion - and then Etype (Expr_N) = Typ - then - Expr_N := Expression (Expr_N); - Set_Expression (N, Expr_N); - 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. - Obj_Id := Make_Temporary (Loc, 'D', Expr_N); - Expr_Typ := Base_Type (Etype (Expr_N)); + declare + Elmt : Elmt_Id; + Subp : Entity_Id; - if Is_Class_Wide_Type (Expr_Typ) then - Expr_Typ := Root_Type (Expr_Typ); - end if; + 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; - -- Replace - -- CW : I'Class := Obj; - -- by - -- Tmp : T := Obj; - -- type Ityp is not null access I'Class; - -- CW : I'Class renames Ityp (Tmp.I_Tag'Address).all; + Next_Elmt (Elmt); + end loop; + end; + end if; - if Comes_From_Source (Expr_N) - and then Nkind (Expr_N) = N_Identifier - and then not Is_Interface (Expr_Typ) - and then Interface_Present_In_Ancestor (Expr_Typ, Typ) - and then (Expr_Typ = Etype (Expr_Typ) - or else not - Is_Variable_Size_Record (Etype (Expr_Typ))) - then - -- Copy the object + -- Create a heterogeneous finalization master to service the anonymous + -- access-to-controlled components of the record type. - Insert_Action (N, - Make_Object_Declaration (Loc, - Defining_Identifier => Obj_Id, - Object_Definition => - New_Occurrence_Of (Expr_Typ, Loc), - Expression => Relocate_Node (Expr_N))); + 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; - -- Statically reference the tag associated with the - -- interface + Attributes_Set : Boolean := False; + Master_Built : Boolean := False; + -- Two flags which control the creation and initialization of a + -- common heterogeneous master. - Tag_Comp := - Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Obj_Id, Loc), - Selector_Name => - New_Occurrence_Of - (Find_Interface_Tag (Expr_Typ, Iface), Loc)); + begin + Comp := First_Component (Typ); + while Present (Comp) loop + Comp_Typ := Etype (Comp); - -- Replace - -- IW : I'Class := Obj; - -- by - -- type Equiv_Record is record ... end record; - -- implicit subtype CW is ; - -- Tmp : CW := CW!(Obj); - -- type Ityp is not null access I'Class; - -- IW : I'Class renames - -- Ityp!(Displace (Temp'Address, I'Tag)).all; + -- A non-self-referential anonymous access-to-controlled + -- component. - else - -- Generate the equivalent record type and update the - -- subtype indication to reference it. + 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. - Expand_Subtype_From_Expr - (N => N, - Unc_Type => Typ, - Subtype_Indic => Obj_Def, - Exp => Expr_N); + if not Master_Built then + Master_Built := True; - if not Is_Interface (Etype (Expr_N)) then - New_Expr := Relocate_Node (Expr_N); + -- 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"). - -- For interface types we use 'Address which displaces - -- the pointer to the base of the object (if required) + Set_Associated_Storage_Pool + (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object)); - else - New_Expr := - Unchecked_Convert_To (Etype (Obj_Def), - Make_Explicit_Dereference (Loc, - Unchecked_Convert_To (RTE (RE_Tag_Ptr), - Make_Attribute_Reference (Loc, - Prefix => Relocate_Node (Expr_N), - Attribute_Name => Name_Address)))); - end if; + Build_Finalization_Master + (Typ => Root_Type (Comp_Typ), + For_Anonymous => True, + Context_Scope => Encl_Scope, + Insertion_Node => Ins_Node); - -- Copy the object + Fin_Mas_Id := Finalization_Master (Comp_Typ); - if not Is_Limited_Record (Expr_Typ) then - Insert_Action (N, - Make_Object_Declaration (Loc, - Defining_Identifier => Obj_Id, - Object_Definition => - New_Occurrence_Of (Etype (Obj_Def), Loc), - Expression => New_Expr)); + -- Subsequent anonymous access-to-controlled components + -- reuse the available master. - -- Rename limited type object since they cannot be copied - -- This case occurs when the initialization expression - -- has been previously expanded into a temporary object. + 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"). - else pragma Assert (not Comes_From_Source (Expr_Q)); - Insert_Action (N, - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Obj_Id, - Subtype_Mark => - New_Occurrence_Of (Etype (Obj_Def), Loc), - Name => - Unchecked_Convert_To - (Etype (Obj_Def), New_Expr))); - end if; + Set_Associated_Storage_Pool + (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object)); - -- Dynamically reference the tag associated with the - -- interface. + -- Shared the master among multiple components - Tag_Comp := - Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (RE_Displace), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Obj_Id, Loc), - Attribute_Name => Name_Address), - New_Occurrence_Of - (Node (First_Elmt (Access_Disp_Table (Iface))), - Loc))); - end if; + Set_Finalization_Master + (Root_Type (Comp_Typ), Fin_Mas_Id); - Rewrite (N, - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Make_Temporary (Loc, 'D'), - Subtype_Mark => New_Occurrence_Of (Typ, Loc), - Name => - Convert_Tag_To_Interface (Typ, Tag_Comp))); + -- Convert the master into a heterogeneous collection. + -- Generate: + -- Set_Is_Heterogeneous (); - -- If the original entity comes from source, then mark the - -- new entity as needing debug information, even though it's - -- defined by a generated renaming that does not come from - -- source, so that Materialize_Entity will be set on the - -- entity when Debug_Renaming_Declaration is called during - -- analysis. + if not Attributes_Set then + Attributes_Set := True; - if Comes_From_Source (Def_Id) then - Set_Debug_Info_Needed (Defining_Identifier (N)); + 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; - Analyze (N, Suppress => All_Checks); + Next_Component (Comp); + end loop; + end; + end if; - -- Replace internal identifier of rewritten node by the - -- identifier found in the sources. We also have to exchange - -- entities containing their defining identifiers to ensure - -- the correct replacement of the object declaration by this - -- object renaming declaration because these identifiers - -- were previously added by Enter_Name to the current scope. - -- We must preserve the homonym chain of the source entity - -- as well. We must also preserve the kind of the entity, - -- which may be a constant. Preserve entity chain because - -- itypes may have been generated already, and the full - -- chain must be preserved for final freezing. Finally, - -- preserve Comes_From_Source setting, so that debugging - -- and cross-referencing information is properly kept, and - -- preserve source location, to prevent spurious errors when - -- entities are declared (they must have their own Sloc). + -- Check whether individual components have a defined invariant, and add + -- the corresponding component invariant checks. - declare - New_Id : constant Entity_Id := Defining_Identifier (N); - Next_Temp : constant Entity_Id := Next_Entity (New_Id); - S_Flag : constant Boolean := - Comes_From_Source (Def_Id); + -- 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. - begin - Set_Next_Entity (New_Id, Next_Entity (Def_Id)); - Set_Next_Entity (Def_Id, Next_Temp); + -- Such objects will show up in a class-wide postcondition, and the + -- invariant will be checked, if necessary, upon return from the + -- enclosing subprogram. - Set_Chars (Defining_Identifier (N), Chars (Def_Id)); - Set_Homonym (Defining_Identifier (N), Homonym (Def_Id)); - Set_Ekind (Defining_Identifier (N), Ekind (Def_Id)); - Set_Sloc (Defining_Identifier (N), Sloc (Def_Id)); + if not Is_Class_Wide_Equivalent_Type (Typ) then + Insert_Component_Invariant_Checks + (N, Typ, Build_Record_Invariant_Proc (Typ, N)); + end if; - Set_Comes_From_Source (Def_Id, False); - Exchange_Entities (Defining_Identifier (N), Def_Id); - Set_Comes_From_Source (Def_Id, S_Flag); - end; - end; - end if; + Ghost_Mode := Save_Ghost_Mode; + end Expand_Freeze_Record_Type; - return; + ------------------------------------ + -- Expand_N_Full_Type_Declaration -- + ------------------------------------ - -- Common case of explicit object initialization + procedure Expand_N_Full_Type_Declaration (N : Node_Id) is + procedure Build_Master (Ptr_Typ : Entity_Id); + -- Create the master associated with Ptr_Typ - else - -- In most cases, we must check that the initial value meets any - -- constraint imposed by the declared type. However, there is one - -- very important exception to this rule. If the entity has an - -- unconstrained nominal subtype, then it acquired its constraints - -- from the expression in the first place, and not only does this - -- mean that the constraint check is not needed, but an attempt to - -- perform the constraint check can cause order of elaboration - -- problems. + ------------------ + -- Build_Master -- + ------------------ - if not Is_Constr_Subt_For_U_Nominal (Typ) then + procedure Build_Master (Ptr_Typ : Entity_Id) is + Desig_Typ : Entity_Id := Designated_Type (Ptr_Typ); - -- If this is an allocator for an aggregate that has been - -- allocated in place, delay checks until assignments are - -- made, because the discriminants are not initialized. + begin + -- If the designated type is an incomplete view coming from a + -- limited-with'ed package, we need to use the nonlimited view in + -- case it has tasks. - if Nkind (Expr) = N_Allocator and then No_Initialization (Expr) - then - null; + if Ekind (Desig_Typ) in Incomplete_Kind + and then Present (Non_Limited_View (Desig_Typ)) + then + Desig_Typ := Non_Limited_View (Desig_Typ); + end if; - -- Otherwise apply a constraint check now if no prev error + -- Anonymous access types are created for the components of the + -- record parameter for an entry declaration. No master is created + -- for such a type. - elsif Nkind (Expr) /= N_Error then - Apply_Constraint_Check (Expr, Typ); + if Comes_From_Source (N) and then Has_Task (Desig_Typ) then + Build_Master_Entity (Ptr_Typ); + Build_Master_Renaming (Ptr_Typ); - -- Deal with possible range check + -- Create a class-wide master because a Master_Id must be generated + -- for access-to-limited-class-wide types whose root may be extended + -- with task components. - if Do_Range_Check (Expr) then + -- Note: This code covers access-to-limited-interfaces because they + -- can be used to reference tasks implementing them. - -- If assignment checks are suppressed, turn off flag + elsif Is_Limited_Class_Wide_Type (Desig_Typ) + and then Tasking_Allowed + then + Build_Class_Wide_Master (Ptr_Typ); + end if; + end Build_Master; - if Suppress_Assignment_Checks (N) then - Set_Do_Range_Check (Expr, False); + -- Local declarations - -- Otherwise generate the range check + Def_Id : constant Entity_Id := Defining_Identifier (N); + B_Id : constant Entity_Id := Base_Type (Def_Id); + FN : Node_Id; + Par_Id : Entity_Id; - else - Generate_Range_Check - (Expr, Typ, CE_Range_Check_Failed); - end if; - end if; - end if; - end if; - - -- If the type is controlled and not inherently limited, then - -- the target is adjusted after the copy and attached to the - -- finalization list. However, no adjustment is done in the case - -- where the object was initialized by a call to a function whose - -- result is built in place, since no copy occurred. (Eventually - -- we plan to support in-place function results for some cases - -- of nonlimited types. ???) Similarly, no adjustment is required - -- if we are going to rewrite the object declaration into a - -- renaming declaration. - - if Needs_Finalization (Typ) - and then not Is_Limited_View (Typ) - and then not Rewrite_As_Renaming - then - Insert_Action_After (Init_After, - Make_Adjust_Call ( - Obj_Ref => New_Occurrence_Of (Def_Id, Loc), - Typ => Base_Typ)); - end if; + -- Start of processing for Expand_N_Full_Type_Declaration - -- For tagged types, when an init value is given, the tag has to - -- be re-initialized separately in order to avoid the propagation - -- of a wrong tag coming from a view conversion unless the type - -- is class wide (in this case the tag comes from the init value). - -- Suppress the tag assignment when not Tagged_Type_Expansion - -- because tags are represented implicitly in objects. Ditto for - -- types that are CPP_CLASS, and for initializations that are - -- aggregates, because they have to have the right tag. + begin + if Is_Access_Type (Def_Id) then + Build_Master (Def_Id); - -- The re-assignment of the tag has to be done even if the object - -- is a constant. The assignment must be analyzed after the - -- declaration. If an address clause follows, this is handled as - -- part of the freeze actions for the object, otherwise insert - -- tag assignment here. + if Ekind (Def_Id) = E_Access_Protected_Subprogram_Type then + Expand_Access_Protected_Subprogram_Type (N); + end if; - Tag_Assign := Make_Tag_Assignment (N); + -- Array of anonymous access-to-task pointers - if Present (Tag_Assign) then - if Present (Following_Address_Clause (N)) then - Ensure_Freeze_Node (Def_Id); + elsif Ada_Version >= Ada_2005 + and then Is_Array_Type (Def_Id) + and then Is_Access_Type (Component_Type (Def_Id)) + and then Ekind (Component_Type (Def_Id)) = E_Anonymous_Access_Type + then + Build_Master (Component_Type (Def_Id)); - else - Insert_Action_After (Init_After, Tag_Assign); - end if; + elsif Has_Task (Def_Id) then + Expand_Previous_Access_Type (Def_Id); - -- Handle C++ constructor calls. Note that we do not check that - -- Typ is a tagged type since the equivalent Ada type of a C++ - -- class that has no virtual methods is an untagged limited - -- record type. + -- Check the components of a record type or array of records for + -- anonymous access-to-task pointers. - elsif Is_CPP_Constructor_Call (Expr) then + elsif Ada_Version >= Ada_2005 + and then (Is_Record_Type (Def_Id) + or else + (Is_Array_Type (Def_Id) + and then Is_Record_Type (Component_Type (Def_Id)))) + then + declare + Comp : Entity_Id; + First : Boolean; + M_Id : Entity_Id; + Typ : Entity_Id; - -- The call to the initialization procedure does NOT freeze the - -- object being initialized. + begin + if Is_Array_Type (Def_Id) then + Comp := First_Entity (Component_Type (Def_Id)); + else + Comp := First_Entity (Def_Id); + end if; - Id_Ref := New_Occurrence_Of (Def_Id, Loc); - Set_Must_Not_Freeze (Id_Ref); - Set_Assignment_OK (Id_Ref); + -- Examine all components looking for anonymous access-to-task + -- types. - Insert_Actions_After (Init_After, - Build_Initialization_Call (Loc, Id_Ref, Typ, - Constructor_Ref => Expr)); + First := True; + while Present (Comp) loop + Typ := Etype (Comp); - -- We remove here the original call to the constructor - -- to avoid its management in the backend + if Ekind (Typ) = E_Anonymous_Access_Type + and then Has_Task (Available_View (Designated_Type (Typ))) + and then No (Master_Id (Typ)) + then + -- Ensure that the record or array type have a _master - Set_Expression (N, Empty); - return; + if First then + Build_Master_Entity (Def_Id); + Build_Master_Renaming (Typ); + M_Id := Master_Id (Typ); - -- Handle initialization of limited tagged types + First := False; - elsif Is_Tagged_Type (Typ) - and then Is_Class_Wide_Type (Typ) - and then Is_Limited_Record (Typ) - then - -- Given that the type is limited we cannot perform a copy. If - -- Expr_Q is the reference to a variable we mark the variable - -- as OK_To_Rename to expand this declaration into a renaming - -- declaration (see bellow). + -- Reuse the same master to service any additional types - if Is_Entity_Name (Expr_Q) then - Set_OK_To_Rename (Entity (Expr_Q)); + else + Set_Master_Id (Typ, M_Id); + end if; + end if; - -- If we cannot convert the expression into a renaming we must - -- consider it an internal error because the backend does not - -- have support to handle it. + Next_Entity (Comp); + end loop; + end; + end if; - else - pragma Assert (False); - raise Program_Error; - end if; + Par_Id := Etype (B_Id); - -- For discrete types, set the Is_Known_Valid flag if the - -- initializing value is known to be valid. Only do this for - -- source assignments, since otherwise we can end up turning - -- on the known valid flag prematurely from inserted code. + -- The parent type is private then we need to inherit any TSS operations + -- from the full view. - elsif Comes_From_Source (N) - and then Is_Discrete_Type (Typ) - and then Expr_Known_Valid (Expr) - then - Set_Is_Known_Valid (Def_Id); + if Ekind (Par_Id) in Private_Kind + and then Present (Full_View (Par_Id)) + then + Par_Id := Base_Type (Full_View (Par_Id)); + end if; - elsif Is_Access_Type (Typ) then + if Nkind (Type_Definition (Original_Node (N))) = + N_Derived_Type_Definition + and then not Is_Tagged_Type (Def_Id) + and then Present (Freeze_Node (Par_Id)) + and then Present (TSS_Elist (Freeze_Node (Par_Id))) + then + Ensure_Freeze_Node (B_Id); + FN := Freeze_Node (B_Id); - -- For access types set the Is_Known_Non_Null flag if the - -- initializing value is known to be non-null. We can also set - -- Can_Never_Be_Null if this is a constant. + if No (TSS_Elist (FN)) then + Set_TSS_Elist (FN, New_Elmt_List); + end if; - if Known_Non_Null (Expr) then - Set_Is_Known_Non_Null (Def_Id, True); + declare + T_E : constant Elist_Id := TSS_Elist (FN); + Elmt : Elmt_Id; - if Constant_Present (N) then - Set_Can_Never_Be_Null (Def_Id); - end if; + begin + Elmt := First_Elmt (TSS_Elist (Freeze_Node (Par_Id))); + while Present (Elmt) loop + if Chars (Node (Elmt)) /= Name_uInit then + Append_Elmt (Node (Elmt), T_E); end if; - end if; - -- If validity checking on copies, validate initial expression. - -- But skip this if declaration is for a generic type, since it - -- makes no sense to validate generic types. Not clear if this - -- can happen for legal programs, but it definitely can arise - -- from previous instantiation errors. + Next_Elmt (Elmt); + end loop; - if Validity_Checks_On - and then Validity_Check_Copies - and then not Is_Generic_Type (Etype (Def_Id)) + -- If the derived type itself is private with a full view, then + -- associate the full view with the inherited TSS_Elist as well. + + if Ekind (B_Id) in Private_Kind + and then Present (Full_View (B_Id)) then - Ensure_Valid (Expr); - Set_Is_Known_Valid (Def_Id); + Ensure_Freeze_Node (Base_Type (Full_View (B_Id))); + Set_TSS_Elist + (Freeze_Node (Base_Type (Full_View (B_Id))), TSS_Elist (FN)); end if; - end if; - - -- Cases where the back end cannot handle the initialization directly - -- In such cases, we expand an assignment that will be appropriately - -- handled by Expand_N_Assignment_Statement. + end; + end if; + end Expand_N_Full_Type_Declaration; - -- The exclusion of the unconstrained case is wrong, but for now it - -- is too much trouble ??? + --------------------------------- + -- Expand_N_Object_Declaration -- + --------------------------------- - if (Is_Possibly_Unaligned_Slice (Expr) - or else (Is_Possibly_Unaligned_Object (Expr) - and then not Represented_As_Scalar (Etype (Expr)))) - and then not (Is_Array_Type (Etype (Expr)) - and then not Is_Constrained (Etype (Expr))) - then - declare - Stat : constant Node_Id := - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Def_Id, Loc), - Expression => Relocate_Node (Expr)); - begin - Set_Expression (N, Empty); - Set_No_Initialization (N); - Set_Assignment_OK (Name (Stat)); - Set_No_Ctrl_Actions (Stat); - Insert_After_And_Analyze (Init_After, Stat); - end; - end if; + procedure Expand_N_Object_Declaration (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + Def_Id : constant Entity_Id := Defining_Identifier (N); + Expr : constant Node_Id := Expression (N); + Obj_Def : constant Node_Id := Object_Definition (N); + Typ : constant Entity_Id := Etype (Def_Id); + Base_Typ : constant Entity_Id := Base_Type (Typ); + Expr_Q : Node_Id; - -- Final transformation, if the initializing expression is an entity - -- for a variable with OK_To_Rename set, then we transform: + function Build_Equivalent_Aggregate return Boolean; + -- If the object has a constrained discriminated type and no initial + -- value, it may be possible to build an equivalent aggregate instead, + -- and prevent an actual call to the initialization procedure. - -- X : typ := expr; + procedure Default_Initialize_Object (After : Node_Id); + -- Generate all default initialization actions for object Def_Id. Any + -- new code is inserted after node After. - -- into + function Rewrite_As_Renaming return Boolean; + -- Indicate whether to rewrite a declaration with initialization into an + -- object renaming declaration (see below). - -- X : typ renames expr - - -- provided that X is not aliased. The aliased case has to be - -- excluded in general because Expr will not be aliased in general. - - if Rewrite_As_Renaming then - Rewrite (N, - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Defining_Identifier (N), - Subtype_Mark => Obj_Def, - Name => Expr_Q)); - - -- We do not analyze this renaming declaration, because all its - -- components have already been analyzed, and if we were to go - -- ahead and analyze it, we would in effect be trying to generate - -- another declaration of X, which won't do. + -------------------------------- + -- Build_Equivalent_Aggregate -- + -------------------------------- - Set_Renamed_Object (Defining_Identifier (N), Expr_Q); - Set_Analyzed (N); + function Build_Equivalent_Aggregate return Boolean is + Aggr : Node_Id; + Comp : Entity_Id; + Discr : Elmt_Id; + Full_Type : Entity_Id; - -- We do need to deal with debug issues for this renaming + begin + Full_Type := Typ; - -- First, if entity comes from source, then mark it as needing - -- debug information, even though it is defined by a generated - -- renaming that does not come from source. + if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then + Full_Type := Full_View (Typ); + end if; - if Comes_From_Source (Defining_Identifier (N)) then - Set_Debug_Info_Needed (Defining_Identifier (N)); - end if; + -- Only perform this transformation if Elaboration_Code is forbidden + -- or undesirable, and if this is a global entity of a constrained + -- record type. - -- Now call the routine to generate debug info for the renaming + -- If Initialize_Scalars might be active this transformation cannot + -- be performed either, because it will lead to different semantics + -- or because elaboration code will in fact be created. - declare - Decl : constant Node_Id := Debug_Renaming_Declaration (N); - begin - if Present (Decl) then - Insert_Action (N, Decl); - end if; - end; + if Ekind (Full_Type) /= E_Record_Subtype + or else not Has_Discriminants (Full_Type) + or else not Is_Constrained (Full_Type) + or else Is_Controlled (Full_Type) + or else Is_Limited_Type (Full_Type) + or else not Restriction_Active (No_Initialize_Scalars) + then + return False; end if; - end if; - - if Nkind (N) = N_Object_Declaration - and then Nkind (Obj_Def) = N_Access_Definition - and then not Is_Local_Anonymous_Access (Etype (Def_Id)) - then - -- An Ada 2012 stand-alone object of an anonymous access type - declare - Loc : constant Source_Ptr := Sloc (N); + if Ekind (Current_Scope) = E_Package + and then + (Restriction_Active (No_Elaboration_Code) + or else Is_Preelaborated (Current_Scope)) + then + -- Building a static aggregate is possible if the discriminants + -- have static values and the other components have static + -- defaults or none. - Level : constant Entity_Id := - Make_Defining_Identifier (Sloc (N), - Chars => - New_External_Name (Chars (Def_Id), Suffix => "L")); + Discr := First_Elmt (Discriminant_Constraint (Full_Type)); + while Present (Discr) loop + if not Is_OK_Static_Expression (Node (Discr)) then + return False; + end if; - Level_Expr : Node_Id; - Level_Decl : Node_Id; + Next_Elmt (Discr); + end loop; - begin - Set_Ekind (Level, Ekind (Def_Id)); - Set_Etype (Level, Standard_Natural); - Set_Scope (Level, Scope (Def_Id)); + -- Check that initialized components are OK, and that non- + -- initialized components do not require a call to their own + -- initialization procedure. - if No (Expr) then + Comp := First_Component (Full_Type); + while Present (Comp) loop + if Ekind (Comp) = E_Component + and then Present (Expression (Parent (Comp))) + and then + not Is_OK_Static_Expression (Expression (Parent (Comp))) + then + return False; - -- Set accessibility level of null + elsif Has_Non_Null_Base_Init_Proc (Etype (Comp)) then + return False; - Level_Expr := - Make_Integer_Literal (Loc, Scope_Depth (Standard_Standard)); + end if; - else - Level_Expr := Dynamic_Accessibility_Level (Expr); - end if; + Next_Component (Comp); + end loop; - Level_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Level, - Object_Definition => - New_Occurrence_Of (Standard_Natural, Loc), - Expression => Level_Expr, - Constant_Present => Constant_Present (N), - Has_Init_Expression => True); + -- Everything is static, assemble the aggregate, discriminant + -- values first. - Insert_Action_After (Init_After, Level_Decl); + Aggr := + Make_Aggregate (Loc, + Expressions => New_List, + Component_Associations => New_List); - Set_Extra_Accessibility (Def_Id, Level); - end; - end if; + Discr := First_Elmt (Discriminant_Constraint (Full_Type)); + while Present (Discr) loop + Append_To (Expressions (Aggr), New_Copy (Node (Discr))); + Next_Elmt (Discr); + end loop; - -- If the object is default initialized and its type is subject to - -- pragma Default_Initial_Condition, add a runtime check to verify - -- the assumption of the pragma (SPARK RM 7.3.3). Generate: + -- Now collect values of initialized components - -- Default_Init_Cond ( (Def_Id)); + Comp := First_Component (Full_Type); + while Present (Comp) loop + if Ekind (Comp) = E_Component + and then Present (Expression (Parent (Comp))) + then + Append_To (Component_Associations (Aggr), + Make_Component_Association (Loc, + Choices => New_List (New_Occurrence_Of (Comp, Loc)), + Expression => New_Copy_Tree + (Expression (Parent (Comp))))); + end if; - -- Note that the check is generated for source objects only + Next_Component (Comp); + end loop; - if Comes_From_Source (Def_Id) - and then (Has_Default_Init_Cond (Typ) - or else - Has_Inherited_Default_Init_Cond (Typ)) - and then not Has_Init_Expression (N) - then - declare - DIC_Call : constant Node_Id := - Build_Default_Init_Cond_Call (Loc, Def_Id, Typ); - begin - if Present (Next_N) then - Insert_Before_And_Analyze (Next_N, DIC_Call); + -- Finally, box-initialize remaining components - -- The object declaration is the last node in a declarative or a - -- statement list. + Append_To (Component_Associations (Aggr), + Make_Component_Association (Loc, + Choices => New_List (Make_Others_Choice (Loc)), + Expression => Empty)); + Set_Box_Present (Last (Component_Associations (Aggr))); + Set_Expression (N, Aggr); + if Typ /= Full_Type then + Analyze_And_Resolve (Aggr, Full_View (Base_Type (Full_Type))); + Rewrite (Aggr, Unchecked_Convert_To (Typ, Aggr)); + Analyze_And_Resolve (Aggr, Typ); else - Append_To (List_Containing (N), DIC_Call); - Analyze (DIC_Call); + Analyze_And_Resolve (Aggr, Full_Type); end if; - end; - end if; - -- Exception on library entity not available + return True; - exception - when RE_Not_Available => - return; - end Expand_N_Object_Declaration; + else + return False; + end if; + end Build_Equivalent_Aggregate; - --------------------------------- - -- Expand_N_Subtype_Indication -- - --------------------------------- + ------------------------------- + -- Default_Initialize_Object -- + ------------------------------- - -- Add a check on the range of the subtype. The static case is partially - -- duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, but we still need - -- to check here for the static case in order to avoid generating - -- extraneous expanded code. Also deal with validity checking. + procedure Default_Initialize_Object (After : Node_Id) is + function New_Object_Reference return Node_Id; + -- Return a new reference to Def_Id with attributes Assignment_OK and + -- Must_Not_Freeze already set. - procedure Expand_N_Subtype_Indication (N : Node_Id) is - Ran : constant Node_Id := Range_Expression (Constraint (N)); - Typ : constant Entity_Id := Entity (Subtype_Mark (N)); + -------------------------- + -- New_Object_Reference -- + -------------------------- - begin - if Nkind (Constraint (N)) = N_Range_Constraint then - Validity_Check_Range (Range_Expression (Constraint (N))); - end if; + function New_Object_Reference return Node_Id is + Obj_Ref : constant Node_Id := New_Occurrence_Of (Def_Id, Loc); - if Nkind_In (Parent (N), N_Constrained_Array_Definition, N_Slice) then - Apply_Range_Check (Ran, Typ); - end if; - end Expand_N_Subtype_Indication; + begin + -- The call to the type init proc or [Deep_]Finalize must not + -- freeze the related object as the call is internally generated. + -- This way legal rep clauses that apply to the object will not be + -- flagged. Note that the initialization call may be removed if + -- pragma Import is encountered or moved to the freeze actions of + -- the object because of an address clause. - --------------------------- - -- Expand_N_Variant_Part -- - --------------------------- + Set_Assignment_OK (Obj_Ref); + Set_Must_Not_Freeze (Obj_Ref); - -- Note: this procedure no longer has any effect. It used to be that we - -- would replace the choices in the last variant by a when others, and - -- also expanded static predicates in variant choices here, but both of - -- those activities were being done too early, since we can't check the - -- choices until the statically predicated subtypes are frozen, which can - -- happen as late as the free point of the record, and we can't change the - -- last choice to an others before checking the choices, which is now done - -- at the freeze point of the record. + return Obj_Ref; + end New_Object_Reference; - procedure Expand_N_Variant_Part (N : Node_Id) is - begin - null; - end Expand_N_Variant_Part; + -- Local variables - --------------------------------- - -- Expand_Previous_Access_Type -- - --------------------------------- + Abrt_Blk : Node_Id; + Abrt_HSS : Node_Id; + Abrt_Id : Entity_Id; + Abrt_Stmts : List_Id; + Aggr_Init : Node_Id; + Comp_Init : List_Id := No_List; + Fin_Call : Node_Id; + Fin_Stmts : List_Id := No_List; + Obj_Init : Node_Id := Empty; + Obj_Ref : Node_Id; - procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is - Ptr_Typ : Entity_Id; + Dummy : Entity_Id; + -- This variable captures a dummy internal entity, see the comment + -- associated with its use. - begin - -- Find all access types in the current scope whose designated type is - -- Def_Id and build master renamings for them. + -- Start of processing for Default_Initialize_Object - Ptr_Typ := First_Entity (Current_Scope); - while Present (Ptr_Typ) loop - if Is_Access_Type (Ptr_Typ) - and then Designated_Type (Ptr_Typ) = Def_Id - and then No (Master_Id (Ptr_Typ)) - then - -- Ensure that the designated type has a master + begin + -- Default initialization is suppressed for objects that are already + -- known to be imported (i.e. whose declaration specifies the Import + -- aspect). Note that for objects with a pragma Import, we generate + -- initialization here, and then remove it downstream when processing + -- the pragma. It is also suppressed for variables for which a pragma + -- Suppress_Initialization has been explicitly given - Build_Master_Entity (Def_Id); + if Is_Imported (Def_Id) or else Suppress_Initialization (Def_Id) then + return; + end if; - -- Private and incomplete types complicate the insertion of master - -- renamings because the access type may precede the full view of - -- the designated type. For this reason, the master renamings are - -- inserted relative to the designated type. + -- Step 1: Initialize the object - Build_Master_Renaming (Ptr_Typ, Ins_Nod => Parent (Def_Id)); + if Needs_Finalization (Typ) and then not No_Initialization (N) then + Obj_Init := + Make_Init_Call + (Obj_Ref => New_Occurrence_Of (Def_Id, Loc), + Typ => Typ); end if; - Next_Entity (Ptr_Typ); - end loop; - end Expand_Previous_Access_Type; + -- Step 2: Initialize the components of the object - ------------------------ - -- Expand_Tagged_Root -- - ------------------------ + -- Do not initialize the components if their initialization is + -- prohibited. - procedure Expand_Tagged_Root (T : Entity_Id) is - Def : constant Node_Id := Type_Definition (Parent (T)); - Comp_List : Node_Id; - Comp_Decl : Node_Id; - Sloc_N : Source_Ptr; + if Has_Non_Null_Base_Init_Proc (Typ) + and then not No_Initialization (N) + and then not Initialization_Suppressed (Typ) + then + -- Do not initialize the components if No_Default_Initialization + -- applies as the actual restriction check will occur later + -- when the object is frozen as it is not known yet whether the + -- object is imported or not. - begin - if Null_Present (Def) then - Set_Component_List (Def, - Make_Component_List (Sloc (Def), - Component_Items => Empty_List, - Variant_Part => Empty, - Null_Present => True)); - end if; + if not Restriction_Active (No_Default_Initialization) then - Comp_List := Component_List (Def); + -- If the values of the components are compile-time known, use + -- their prebuilt aggregate form directly. - if Null_Present (Comp_List) - or else Is_Empty_List (Component_Items (Comp_List)) - then - Sloc_N := Sloc (Comp_List); - else - Sloc_N := Sloc (First (Component_Items (Comp_List))); - end if; + Aggr_Init := Static_Initialization (Base_Init_Proc (Typ)); - Comp_Decl := - Make_Component_Declaration (Sloc_N, - Defining_Identifier => First_Tag_Component (T), - Component_Definition => - Make_Component_Definition (Sloc_N, - Aliased_Present => False, - Subtype_Indication => New_Occurrence_Of (RTE (RE_Tag), Sloc_N))); + if Present (Aggr_Init) then + Set_Expression + (N, New_Copy_Tree (Aggr_Init, New_Scope => Current_Scope)); - if 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); + -- If type has discriminants, try to build an equivalent + -- aggregate using discriminant values from the declaration. + -- This is a useful optimization, in particular if restriction + -- No_Elaboration_Code is active. - else - Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); - end if; + elsif Build_Equivalent_Aggregate then + null; - -- We don't Analyze the whole expansion because the tag component has - -- already been analyzed previously. Here we just insure that the tree - -- is coherent with the semantic decoration + -- Otherwise invoke the type init proc - Find_Type (Subtype_Indication (Component_Definition (Comp_Decl))); + else + Obj_Ref := New_Object_Reference; - exception - when RE_Not_Available => - return; - end Expand_Tagged_Root; + if Comes_From_Source (Def_Id) then + Initialization_Warning (Obj_Ref); + end if; - ---------------------- - -- Clean_Task_Names -- - ---------------------- + Comp_Init := Build_Initialization_Call (Loc, Obj_Ref, Typ); + end if; + end if; - 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; + -- Provide a default value if the object needs simple initialization + -- and does not already have an initial value. A generated temporary + -- does not require initialization because it will be assigned later. - ------------------------------ - -- Expand_Freeze_Array_Type -- - ------------------------------ + elsif Needs_Simple_Initialization + (Typ, Initialize_Scalars + and then No (Following_Address_Clause (N))) + and then not Is_Internal (Def_Id) + and then not Has_Init_Expression (N) + then + Set_No_Initialization (N, False); + Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id))); + Analyze_And_Resolve (Expression (N), Typ); + end if; - 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; + -- Step 3: Add partial finalization and abort actions, generate: - begin - if not Is_Bit_Packed_Array (Typ) then + -- Type_Init_Proc (Obj); + -- begin + -- Deep_Initialize (Obj); + -- exception + -- when others => + -- Deep_Finalize (Obj, Self => False); + -- raise; + -- end; - -- 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. + -- Step 3a: Build the finalization block (if applicable) - 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)); + -- The finalization block is required when both the object and its + -- controlled components are to be initialized. The block finalizes + -- the components if the object initialization fails. - if No (Init_Proc (Base)) then + if Has_Controlled_Component (Typ) + and then Present (Comp_Init) + and then Present (Obj_Init) + and then not Restriction_Active (No_Exception_Propagation) + then + -- Generate: + -- Type_Init_Proc (Obj); - -- 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. + Fin_Stmts := Comp_Init; - 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; + -- Generate: + -- begin + -- Deep_Initialize (Obj); + -- exception + -- when others => + -- Deep_Finalize (Obj, Self => False); + -- raise; + -- end; - -- 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. + Fin_Call := + Make_Final_Call + (Obj_Ref => New_Object_Reference, + Typ => Typ, + Skip_Self => True); - elsif Is_Standard_String_Type (Base) then - null; + if Present (Fin_Call) then - -- Otherwise we have to build an init proc for the subtype + -- Do not emit warnings related to the elaboration order when a + -- controlled object is declared before the body of Finalize is + -- seen. - else - Build_Array_Init_Proc (Base, N); - end if; - end if; + Set_No_Elaboration_Check (Fin_Call); - if Typ = Base then - if Has_Controlled_Component (Base) then - Build_Controlling_Procs (Base); + Append_To (Fin_Stmts, + Make_Block_Statement (Loc, + Declarations => No_List, - if not Is_Limited_Type (Comp_Typ) - and then Number_Dimensions (Typ) = 1 - then - Build_Slice_Assignment (Typ); - end if; + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Obj_Init), + + Exception_Handlers => New_List ( + Make_Exception_Handler (Loc, + Exception_Choices => New_List ( + Make_Others_Choice (Loc)), + + Statements => New_List ( + Fin_Call, + Make_Raise_Statement (Loc))))))); end if; - -- Create a finalization master to service the anonymous access - -- components of the array. + -- Finalization is not required, the initialization calls are passed + -- to the abort block building circuitry, generate: - 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. + -- Type_Init_Proc (Obj); + -- Deep_Initialize (Obj); - if Is_Itype (Typ) then - Ins_Node := Associated_Node_For_Itype (Typ); - else - Ins_Node := Parent (Typ); + else + if Present (Comp_Init) then + Fin_Stmts := Comp_Init; + end if; + + if Present (Obj_Init) then + if No (Fin_Stmts) then + Fin_Stmts := New_List; end if; - Build_Finalization_Master - (Typ => Comp_Typ, - For_Anonymous => True, - Context_Scope => Scope (Typ), - Insertion_Node => Ins_Node); + Append_To (Fin_Stmts, Obj_Init); 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; + -- Step 3b: Build the abort block (if applicable) - 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. + -- The abort block is required when aborts are allowed in order to + -- protect both initialization calls. - Insert_Component_Invariant_Checks - (N, Base, Build_Array_Invariant_Proc (Base, N)); - end if; - end Expand_Freeze_Array_Type; + if Present (Comp_Init) and then Present (Obj_Init) then + if Abort_Allowed then - ----------------------------------- - -- Expand_Freeze_Class_Wide_Type -- - ----------------------------------- + -- Generate: + -- Abort_Defer; - procedure Expand_Freeze_Class_Wide_Type (N : Node_Id) is - Typ : constant Entity_Id := Entity (N); - Root : constant Entity_Id := Root_Type (Typ); + Prepend_To + (Fin_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); - function Is_C_Derivation (Typ : Entity_Id) return Boolean; - -- Given a type, determine whether it is derived from a C or C++ root + -- Generate: + -- begin + -- Abort_Defer; + -- + -- at end + -- Abort_Undefer_Direct; + -- end; - --------------------- - -- Is_C_Derivation -- - --------------------- + declare + AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct); - function Is_C_Derivation (Typ : Entity_Id) return Boolean is - T : Entity_Id; + begin + Abrt_HSS := + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Fin_Stmts, + At_End_Proc => New_Occurrence_Of (AUD, Loc)); - 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; + -- Present the Abort_Undefer_Direct function to the backend + -- so that it can inline the call to the function. - exit when T = Etype (T); + Add_Inlined_Body (AUD, N); + end; - T := Etype (T); - end loop; + Abrt_Blk := + Make_Block_Statement (Loc, + Declarations => No_List, + Handled_Statement_Sequence => Abrt_HSS); - return False; - end Is_C_Derivation; + Add_Block_Identifier (Abrt_Blk, Abrt_Id); + Expand_At_End_Handler (Abrt_HSS, Abrt_Id); - -- Start of processing for Expand_Freeze_Class_Wide_Type + Abrt_Stmts := New_List (Abrt_Blk); - begin - -- Certain run-time configurations and targets do not provide support - -- for controlled types. + -- Abort is not required - if Restriction_Active (No_Finalization) then - return; + else + -- Generate a dummy entity to ensure that the internal symbols + -- are in sync when a unit is compiled with and without aborts. + -- The entity is a block with proper scope and type. - -- Do not create TSS routine Finalize_Address when dispatching calls are - -- disabled since the core of the routine is a dispatching call. + Dummy := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); + Set_Etype (Dummy, Standard_Void_Type); + Abrt_Stmts := Fin_Stmts; + end if; - elsif Restriction_Active (No_Dispatching_Calls) then - return; + -- No initialization calls present - -- 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. + else + Abrt_Stmts := Fin_Stmts; + end if; - elsif Is_Concurrent_Type (Root) - or else Is_C_Derivation (Root) - or else Convention (Typ) = Convention_CPP - then - return; + -- Step 4: Insert the whole initialization sequence into the tree + -- If the object has a delayed freeze, as will be the case when + -- it has aspect specifications, the initialization sequence is + -- part of the freeze actions. - -- Do not create TSS routine Finalize_Address when compiling in CodePeer - -- mode since the routine contains an Unchecked_Conversion. + if Has_Delayed_Freeze (Def_Id) then + Append_Freeze_Actions (Def_Id, Abrt_Stmts); + else + Insert_Actions_After (After, Abrt_Stmts); + end if; + end Default_Initialize_Object; - elsif CodePeer_Mode then - return; - end if; + ------------------------- + -- Rewrite_As_Renaming -- + ------------------------- - -- Create the body of TSS primitive Finalize_Address. This automatically - -- sets the TSS entry for the class-wide type. + function Rewrite_As_Renaming return Boolean is + begin + return not Aliased_Present (N) + and then Is_Entity_Name (Expr_Q) + and then Ekind (Entity (Expr_Q)) = E_Variable + and then OK_To_Rename (Entity (Expr_Q)) + and then Is_Entity_Name (Obj_Def); + end Rewrite_As_Renaming; - Make_Finalize_Address_Body (Typ); - end Expand_Freeze_Class_Wide_Type; + -- Local variables - ------------------------------------ - -- Expand_Freeze_Enumeration_Type -- - ------------------------------------ + Next_N : constant Node_Id := Next (N); + Id_Ref : Node_Id; + Tag_Assign : Node_Id; - 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; + Init_After : Node_Id := N; + -- Node after which the initialization actions are to be inserted. This + -- is normally N, except for the case of a shared passive variable, in + -- which case the init proc call must be inserted only after the bodies + -- of the shared variable procedures have been seen. - Func : Entity_Id; - pragma Warnings (Off, Func); + -- Start of processing for Expand_N_Object_Declaration begin - -- Various optimizations possible if given representation is contiguous + -- Don't do anything for deferred constants. All proper actions will be + -- expanded during the full declaration. - Is_Contiguous := True; + if No (Expr) and Constant_Present (N) then + return; + end if; - Ent := First_Literal (Typ); - Last_Repval := Enumeration_Rep (Ent); + -- The type of the object cannot be abstract. This is diagnosed at the + -- point the object is frozen, which happens after the declaration is + -- fully expanded, so simply return now. - 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; + if Is_Abstract_Type (Typ) then + return; + end if; - Next_Literal (Ent); - end loop; + -- First we do special processing for objects of a tagged type where + -- this is the point at which the type is frozen. The creation of the + -- dispatch table and the initialization procedure have to be deferred + -- to this point, since we reference previously declared primitive + -- subprograms. - if Is_Contiguous then - Set_Has_Contiguous_Rep (Typ); - Ent := First_Literal (Typ); - Num := 1; - Lst := New_List (New_Occurrence_Of (Ent, Sloc (Ent))); + -- Force construction of dispatch tables of library level tagged types - else - -- Build list of literal references + if Tagged_Type_Expansion + and then Static_Dispatch_Tables + and then Is_Library_Level_Entity (Def_Id) + and then Is_Library_Level_Tagged_Type (Base_Typ) + and then Ekind_In (Base_Typ, E_Record_Type, + E_Protected_Type, + E_Task_Type) + and then not Has_Dispatch_Table (Base_Typ) + then + declare + New_Nodes : List_Id := No_List; - Lst := New_List; - Num := 0; + begin + if Is_Concurrent_Type (Base_Typ) then + New_Nodes := Make_DT (Corresponding_Record_Type (Base_Typ), N); + else + New_Nodes := Make_DT (Base_Typ, N); + end if; - 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; + if not Is_Empty_List (New_Nodes) then + Insert_List_Before (N, New_Nodes); + end if; + end; end if; - -- Now build an array declaration + -- Make shared memory routines for shared passive variable - -- typA : array (Natural range 0 .. num - 1) of ctype := - -- (v, v, v, v, v, ....) + if Is_Shared_Passive (Def_Id) then + Init_After := Make_Shared_Var_Procs (N); + end if; - -- 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. + -- If tasks being declared, make sure we have an activation chain + -- defined for the tasks (has no effect if we already have one), and + -- also that a Master variable is established and that the appropriate + -- enclosing construct is established as a task master. - Arr := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), 'A')); + if Has_Task (Typ) then + Build_Activation_Chain_Entity (N); + Build_Master_Entity (Def_Id); + end if; - Append_Freeze_Action (Typ, - Make_Object_Declaration (Loc, - Defining_Identifier => Arr, - Constant_Present => True, + -- Default initialization required, and no expression present - 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))))), + if No (Expr) then - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => New_Occurrence_Of (Typ, Loc))), + -- If we have a type with a variant part, the initialization proc + -- will contain implicit tests of the discriminant values, which + -- counts as a violation of the restriction No_Implicit_Conditionals. - Expression => - Make_Aggregate (Loc, - Expressions => Lst))); + if Has_Variant_Part (Typ) then + declare + Msg : Boolean; - Set_Enum_Pos_To_Rep (Typ, Arr); + begin + Check_Restriction (Msg, No_Implicit_Conditionals, Obj_Def); - -- Now we build the function that converts representation values to - -- position values. This function has the form: + if Msg then + Error_Msg_N + ("\initialization of variant record tests discriminants", + Obj_Def); + return; + end if; + end; + end if; - -- 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; + -- For the default initialization case, if we have a private type + -- with invariants, and invariant checks are enabled, then insert an + -- invariant check after the object declaration. Note that it is OK + -- to clobber the object with an invalid value since if the exception + -- is raised, then the object will go out of scope. In the case where + -- an array object is initialized with an aggregate, the expression + -- is removed. Check flag Has_Init_Expression to avoid generating a + -- junk invariant check and flag No_Initialization to avoid checking + -- an uninitialized object such as a compiler temporary used for an + -- aggregate. - -- 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. + if Has_Invariants (Base_Typ) + and then Present (Invariant_Procedure (Base_Typ)) + and then not Has_Init_Expression (N) + and then not No_Initialization (N) + then + -- If entity has an address clause or aspect, make invariant + -- call into a freeze action for the explicit freeze node for + -- object. Otherwise insert invariant check after declaration. - -- 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. + if Present (Following_Address_Clause (N)) + or else Has_Aspect (Def_Id, Aspect_Address) + then + Ensure_Freeze_Node (Def_Id); + Set_Has_Delayed_Freeze (Def_Id); + Set_Is_Frozen (Def_Id, False); - -- 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. + if not Partial_View_Has_Unknown_Discr (Typ) then + Append_Freeze_Action (Def_Id, + Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc))); + end if; - -- Is this right??? What about No_Exception_Propagation??? + elsif not Partial_View_Has_Unknown_Discr (Typ) then + Insert_After (N, + Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc))); + end if; + end if; - -- Representations are signed + Default_Initialize_Object (Init_After); - if Enumeration_Rep (First_Literal (Typ)) < 0 then + -- Generate attribute for Persistent_BSS if needed - -- The underlying type is signed. Reset the Is_Unsigned_Type - -- explicitly, because it might have been inherited from - -- parent type. + if Persistent_BSS_Mode + and then Comes_From_Source (N) + and then Is_Potentially_Persistent_Type (Typ) + and then not Has_Init_Expression (N) + and then Is_Library_Level_Entity (Def_Id) + then + declare + Prag : Node_Id; + begin + Prag := + Make_Linker_Section_Pragma + (Def_Id, Sloc (N), ".persistent.bss"); + Insert_After (N, Prag); + Analyze (Prag); + end; + end if; - Set_Is_Unsigned_Type (Typ, False); + -- If access type, then we know it is null if not initialized - if Esize (Typ) <= Standard_Integer_Size then - Ityp := Standard_Integer; - else - Ityp := Universal_Integer; + if Is_Access_Type (Typ) then + Set_Is_Known_Null (Def_Id); end if; - -- Representations are unsigned + -- Explicit initialization present else - if Esize (Typ) <= Standard_Integer_Size then - Ityp := RTE (RE_Unsigned); + -- Obtain actual expression from qualified expression + + if Nkind (Expr) = N_Qualified_Expression then + Expr_Q := Expression (Expr); else - Ityp := RTE (RE_Long_Long_Unsigned); + Expr_Q := Expr; end if; - end if; - -- The body of the function is a case statement. First collect case - -- alternatives, or optimize the contiguous case. + -- When we have the appropriate type of aggregate in the expression + -- (it has been determined during analysis of the aggregate by + -- setting the delay flag), let's perform in place assignment and + -- thus avoid creating a temporary. - Lst := New_List; + if Is_Delayed_Aggregate (Expr_Q) then + Convert_Aggr_In_Object_Decl (N); - -- If representation is contiguous, Pos is computed by subtracting - -- the representation of the first literal. + -- Ada 2005 (AI-318-02): If the initialization expression is a call + -- to a build-in-place function, then access to the declared object + -- must be passed to the function. Currently we limit such functions + -- to those with constrained limited result subtypes, but eventually + -- plan to expand the allowed forms of functions that are treated as + -- build-in-place. - if Is_Contiguous then - Ent := First_Literal (Typ); + elsif Ada_Version >= Ada_2005 + and then Is_Build_In_Place_Function_Call (Expr_Q) + then + Make_Build_In_Place_Call_In_Object_Declaration (N, Expr_Q); - if Enumeration_Rep (Ent) = Last_Repval then + -- The previous call expands the expression initializing the + -- built-in-place object into further code that will be analyzed + -- later. No further expansion needed here. - -- Another special case: for a single literal, Pos is zero + return; - Pos_Expr := Make_Integer_Literal (Loc, Uint_0); + -- Ada 2005 (AI-251): Rewrite the expression that initializes a + -- class-wide interface object to ensure that we copy the full + -- object, unless we are targetting a VM where interfaces are handled + -- by VM itself. Note that if the root type of Typ is an ancestor of + -- Expr's type, both types share the same dispatch table and there is + -- no need to displace the pointer. - 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; + elsif Is_Interface (Typ) - 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))), + -- Avoid never-ending recursion because if Equivalent_Type is set + -- then we've done it already and must not do it again. - Statements => New_List ( - Make_Simple_Return_Statement (Loc, - Expression => Pos_Expr)))); + and then not + (Nkind (Obj_Def) = N_Identifier + and then Present (Equivalent_Type (Entity (Obj_Def)))) + then + pragma Assert (Is_Class_Wide_Type (Typ)); - 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))), + -- If the object is a return object of an inherently limited type, + -- which implies build-in-place treatment, bypass the special + -- treatment of class-wide interface initialization below. In this + -- case, the expansion of the return statement will take care of + -- creating the object (via allocator) and initializing it. - Statements => New_List ( - Make_Simple_Return_Statement (Loc, - Expression => - Make_Integer_Literal (Loc, - Intval => Enumeration_Pos (Ent)))))); + if Is_Return_Object (Def_Id) and then Is_Limited_View (Typ) then + null; - Next_Literal (Ent); - end loop; - end if; + elsif Tagged_Type_Expansion then + declare + Iface : constant Entity_Id := Root_Type (Typ); + Expr_N : Node_Id := Expr; + Expr_Typ : Entity_Id; + New_Expr : Node_Id; + Obj_Id : Entity_Id; + Tag_Comp : Node_Id; - -- In normal mode, add the others clause with the test + begin + -- If the original node of the expression was a conversion + -- to this specific class-wide interface type then restore + -- the original node because we must copy the object before + -- displacing the pointer to reference the secondary tag + -- component. This code must be kept synchronized with the + -- expansion done by routine Expand_Interface_Conversion - 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 not Comes_From_Source (Expr_N) + and then Nkind (Expr_N) = N_Explicit_Dereference + and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion + and then Etype (Original_Node (Expr_N)) = Typ + then + Rewrite (Expr_N, Original_Node (Expression (N))); + end if; - -- 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. + -- Avoid expansion of redundant interface conversion - 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; + if Is_Interface (Etype (Expr_N)) + and then Nkind (Expr_N) = N_Type_Conversion + and then Etype (Expr_N) = Typ + then + Expr_N := Expression (Expr_N); + Set_Expression (N, Expr_N); + end if; - -- Now we can build the function body + Obj_Id := Make_Temporary (Loc, 'D', Expr_N); + Expr_Typ := Base_Type (Etype (Expr_N)); - Fent := - Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos)); + if Is_Class_Wide_Type (Expr_Typ) then + Expr_Typ := Root_Type (Expr_Typ); + end if; - 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))), + -- Replace + -- CW : I'Class := Obj; + -- by + -- Tmp : T := Obj; + -- type Ityp is not null access I'Class; + -- CW : I'Class renames Ityp (Tmp.I_Tag'Address).all; - Result_Definition => New_Occurrence_Of (Standard_Integer, Loc)), + if Comes_From_Source (Expr_N) + and then Nkind (Expr_N) = N_Identifier + and then not Is_Interface (Expr_Typ) + and then Interface_Present_In_Ancestor (Expr_Typ, Typ) + and then (Expr_Typ = Etype (Expr_Typ) + or else not + Is_Variable_Size_Record (Etype (Expr_Typ))) + then + -- Copy the object - Declarations => Empty_List, + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Obj_Id, + Object_Definition => + New_Occurrence_Of (Expr_Typ, Loc), + Expression => Relocate_Node (Expr_N))); - 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)))); + -- Statically reference the tag associated with the + -- interface - Set_TSS (Typ, Fent); + Tag_Comp := + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Obj_Id, Loc), + Selector_Name => + New_Occurrence_Of + (Find_Interface_Tag (Expr_Typ, Iface), Loc)); - -- 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). + -- Replace + -- IW : I'Class := Obj; + -- by + -- type Equiv_Record is record ... end record; + -- implicit subtype CW is ; + -- Tmp : CW := CW!(Obj); + -- type Ityp is not null access I'Class; + -- IW : I'Class renames + -- Ityp!(Displace (Temp'Address, I'Tag)).all; - Set_Is_Pure (Fent); - Set_Has_Pragma_Pure_Function (Fent); + else + -- Generate the equivalent record type and update the + -- subtype indication to reference it. - -- 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. + Expand_Subtype_From_Expr + (N => N, + Unc_Type => Typ, + Subtype_Indic => Obj_Def, + Exp => Expr_N); - if not Debug_Generated_Code then - Set_Debug_Info_Off (Fent); - end if; + if not Is_Interface (Etype (Expr_N)) then + New_Expr := Relocate_Node (Expr_N); - exception - when RE_Not_Available => - return; - end Expand_Freeze_Enumeration_Type; + -- For interface types we use 'Address which displaces + -- the pointer to the base of the object (if required) - ------------------------------- - -- Expand_Freeze_Record_Type -- - ------------------------------- + else + New_Expr := + Unchecked_Convert_To (Etype (Obj_Def), + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RTE (RE_Tag_Ptr), + Make_Attribute_Reference (Loc, + Prefix => Relocate_Node (Expr_N), + Attribute_Name => Name_Address)))); + end if; - 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; + -- Copy the object - 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. + if not Is_Limited_Record (Expr_Typ) then + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Obj_Id, + Object_Definition => + New_Occurrence_Of (Etype (Obj_Def), Loc), + Expression => New_Expr)); + + -- Rename limited type object since they cannot be copied + -- This case occurs when the initialization expression + -- has been previously expanded into a temporary object. + + else pragma Assert (not Comes_From_Source (Expr_Q)); + Insert_Action (N, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Obj_Id, + Subtype_Mark => + New_Occurrence_Of (Etype (Obj_Def), Loc), + Name => + Unchecked_Convert_To + (Etype (Obj_Def), New_Expr))); + end if; + + -- Dynamically reference the tag associated with the + -- interface. + + Tag_Comp := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_Displace), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Obj_Id, Loc), + Attribute_Name => Name_Address), + New_Occurrence_Of + (Node (First_Elmt (Access_Disp_Table (Iface))), + Loc))); + end if; + + Rewrite (N, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'D'), + Subtype_Mark => New_Occurrence_Of (Typ, Loc), + Name => + Convert_Tag_To_Interface (Typ, Tag_Comp))); + + -- If the original entity comes from source, then mark the + -- new entity as needing debug information, even though it's + -- defined by a generated renaming that does not come from + -- source, so that Materialize_Entity will be set on the + -- entity when Debug_Renaming_Declaration is called during + -- analysis. + + if Comes_From_Source (Def_Id) then + Set_Debug_Info_Needed (Defining_Identifier (N)); + end if; + + Analyze (N, Suppress => All_Checks); + + -- Replace internal identifier of rewritten node by the + -- identifier found in the sources. We also have to exchange + -- entities containing their defining identifiers to ensure + -- the correct replacement of the object declaration by this + -- object renaming declaration because these identifiers + -- were previously added by Enter_Name to the current scope. + -- We must preserve the homonym chain of the source entity + -- as well. We must also preserve the kind of the entity, + -- which may be a constant. Preserve entity chain because + -- itypes may have been generated already, and the full + -- chain must be preserved for final freezing. Finally, + -- preserve Comes_From_Source setting, so that debugging + -- and cross-referencing information is properly kept, and + -- preserve source location, to prevent spurious errors when + -- entities are declared (they must have their own Sloc). + + declare + New_Id : constant Entity_Id := Defining_Identifier (N); + Next_Temp : constant Entity_Id := Next_Entity (New_Id); + S_Flag : constant Boolean := + Comes_From_Source (Def_Id); + + begin + Set_Next_Entity (New_Id, Next_Entity (Def_Id)); + Set_Next_Entity (Def_Id, Next_Temp); + + Set_Chars (Defining_Identifier (N), Chars (Def_Id)); + Set_Homonym (Defining_Identifier (N), Homonym (Def_Id)); + Set_Ekind (Defining_Identifier (N), Ekind (Def_Id)); + Set_Sloc (Defining_Identifier (N), Sloc (Def_Id)); + + Set_Comes_From_Source (Def_Id, False); + Exchange_Entities (Defining_Identifier (N), Def_Id); + Set_Comes_From_Source (Def_Id, S_Flag); + end; + end; + end if; + + return; + + -- Common case of explicit object initialization + + else + -- In most cases, we must check that the initial value meets any + -- constraint imposed by the declared type. However, there is one + -- very important exception to this rule. If the entity has an + -- unconstrained nominal subtype, then it acquired its constraints + -- from the expression in the first place, and not only does this + -- mean that the constraint check is not needed, but an attempt to + -- perform the constraint check can cause order of elaboration + -- problems. + + if not Is_Constr_Subt_For_U_Nominal (Typ) then + + -- If this is an allocator for an aggregate that has been + -- allocated in place, delay checks until assignments are + -- made, because the discriminants are not initialized. + + if Nkind (Expr) = N_Allocator and then No_Initialization (Expr) + then + null; + + -- Otherwise apply a constraint check now if no prev error + + elsif Nkind (Expr) /= N_Error then + Apply_Constraint_Check (Expr, Typ); + + -- Deal with possible range check + + if Do_Range_Check (Expr) then - Wrapper_Decl_List : List_Id := No_List; - Wrapper_Body_List : List_Id := No_List; + -- If assignment checks are suppressed, turn off flag - -- Start of processing for Expand_Freeze_Record_Type + if Suppress_Assignment_Checks (N) then + Set_Do_Range_Check (Expr, False); - 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. + -- Otherwise generate the range check - 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); + else + Generate_Range_Check + (Expr, Typ, CE_Range_Check_Failed); + end if; + end if; + end if; + end if; - elsif Is_Derived_Type (Def_Id) - and then not Is_Tagged_Type (Def_Id) + -- If the type is controlled and not inherently limited, then + -- the target is adjusted after the copy and attached to the + -- finalization list. However, no adjustment is done in the case + -- where the object was initialized by a call to a function whose + -- result is built in place, since no copy occurred. (Eventually + -- we plan to support in-place function results for some cases + -- of nonlimited types. ???) Similarly, no adjustment is required + -- if we are going to rewrite the object declaration into a + -- renaming declaration. - -- 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. + if Needs_Finalization (Typ) + and then not Is_Limited_View (Typ) + and then not Rewrite_As_Renaming + then + Insert_Action_After (Init_After, + Make_Adjust_Call ( + Obj_Ref => New_Occurrence_Of (Def_Id, Loc), + Typ => Base_Typ)); + end if; - and then not Is_Unchecked_Union (Def_Id) - and then Has_Discriminants (Def_Id) - then - declare - Old_Comp : Entity_Id; + -- For tagged types, when an init value is given, the tag has to + -- be re-initialized separately in order to avoid the propagation + -- of a wrong tag coming from a view conversion unless the type + -- is class wide (in this case the tag comes from the init value). + -- Suppress the tag assignment when not Tagged_Type_Expansion + -- because tags are represented implicitly in objects. Ditto for + -- types that are CPP_CLASS, and for initializations that are + -- aggregates, because they have to have the right tag. - 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; + -- The re-assignment of the tag has to be done even if the object + -- is a constant. The assignment must be analyzed after the + -- declaration. If an address clause follows, this is handled as + -- part of the freeze actions for the object, otherwise insert + -- tag assignment here. - Next_Component (Old_Comp); - Next_Component (Comp); - end loop; - end; - end if; + Tag_Assign := Make_Tag_Assignment (N); - 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; + if Present (Tag_Assign) then + if Present (Following_Address_Clause (N)) then + Ensure_Freeze_Node (Def_Id); - -- 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. + else + Insert_Action_After (Init_After, Tag_Assign); + end if; - Has_AACC := False; + -- Handle C++ constructor calls. Note that we do not check that + -- Typ is a tagged type since the equivalent Ada type of a C++ + -- class that has no virtual methods is an untagged limited + -- record type. - Comp := First_Component (Def_Id); - while Present (Comp) loop - Comp_Typ := Etype (Comp); + elsif Is_CPP_Constructor_Call (Expr) then - if Has_Task (Comp_Typ) then - Set_Has_Task (Def_Id); - end if; + -- The call to the initialization procedure does NOT freeze the + -- object being initialized. - if Has_Protected (Comp_Typ) then - Set_Has_Protected (Def_Id); - end if; + Id_Ref := New_Occurrence_Of (Def_Id, Loc); + Set_Must_Not_Freeze (Id_Ref); + Set_Assignment_OK (Id_Ref); - -- Do not set Has_Controlled_Component on a class-wide equivalent - -- type. See Make_CW_Equivalent_Type. + Insert_Actions_After (Init_After, + Build_Initialization_Call (Loc, Id_Ref, Typ, + Constructor_Ref => Expr)); - 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; + -- We remove here the original call to the constructor + -- to avoid its management in the backend - -- Non-self-referential anonymous access-to-controlled component + Set_Expression (N, Empty); + return; - 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; + -- Handle initialization of limited tagged types - Next_Component (Comp); - end loop; + elsif Is_Tagged_Type (Typ) + and then Is_Class_Wide_Type (Typ) + and then Is_Limited_Record (Typ) + then + -- Given that the type is limited we cannot perform a copy. If + -- Expr_Q is the reference to a variable we mark the variable + -- as OK_To_Rename to expand this declaration into a renaming + -- declaration (see bellow). - -- Handle constructors of untagged CPP_Class types + if Is_Entity_Name (Expr_Q) then + Set_OK_To_Rename (Entity (Expr_Q)); - if not Is_Tagged_Type (Def_Id) and then Is_CPP_Class (Def_Id) then - Set_CPP_Constructors (Def_Id); - end if; + -- If we cannot convert the expression into a renaming we must + -- consider it an internal error because the backend does not + -- have support to handle it. - -- 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. + else + pragma Assert (False); + raise Program_Error; + end if; - if Is_Tagged_Type (Def_Id) then + -- For discrete types, set the Is_Known_Valid flag if the + -- initializing value is known to be valid. Only do this for + -- source assignments, since otherwise we can end up turning + -- on the known valid flag prematurely from inserted code. - -- Add the _Tag component + elsif Comes_From_Source (N) + and then Is_Discrete_Type (Typ) + and then Expr_Known_Valid (Expr) + then + Set_Is_Known_Valid (Def_Id); - if Underlying_Type (Etype (Def_Id)) = Def_Id then - Expand_Tagged_Root (Def_Id); - end if; + elsif Is_Access_Type (Typ) then - if Is_CPP_Class (Def_Id) then - Set_All_DT_Position (Def_Id); + -- For access types set the Is_Known_Non_Null flag if the + -- initializing value is known to be non-null. We can also set + -- Can_Never_Be_Null if this is a constant. - -- Create the tag entities with a minimum decoration + if Known_Non_Null (Expr) then + Set_Is_Known_Non_Null (Def_Id, True); - if Tagged_Type_Expansion then - Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id)); + if Constant_Present (N) then + Set_Can_Never_Be_Null (Def_Id); + end if; + end if; end if; - Set_CPP_Constructors (Def_Id); - - else - if not Building_Static_DT (Def_Id) then + -- If validity checking on copies, validate initial expression. + -- But skip this if declaration is for a generic type, since it + -- makes no sense to validate generic types. Not clear if this + -- can happen for legal programs, but it definitely can arise + -- from previous instantiation errors. - -- 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. + if Validity_Checks_On + and then Validity_Check_Copies + and then not Is_Generic_Type (Etype (Def_Id)) + then + Ensure_Valid (Expr); + Set_Is_Known_Valid (Def_Id); + end if; + end if; - -- 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. + -- Cases where the back end cannot handle the initialization directly + -- In such cases, we expand an assignment that will be appropriately + -- handled by Expand_N_Assignment_Statement. - declare - Elmt : Elmt_Id; - Subp : Entity_Id; + -- The exclusion of the unconstrained case is wrong, but for now it + -- is too much trouble ??? - begin - Elmt := First_Elmt (Primitive_Operations (Def_Id)); - while Present (Elmt) loop - Subp := Node (Elmt); + if (Is_Possibly_Unaligned_Slice (Expr) + or else (Is_Possibly_Unaligned_Object (Expr) + and then not Represented_As_Scalar (Etype (Expr)))) + and then not (Is_Array_Type (Etype (Expr)) + and then not Is_Constrained (Etype (Expr))) + then + declare + Stat : constant Node_Id := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Def_Id, Loc), + Expression => Relocate_Node (Expr)); + begin + Set_Expression (N, Empty); + Set_No_Initialization (N); + Set_Assignment_OK (Name (Stat)); + Set_No_Ctrl_Actions (Stat); + Insert_After_And_Analyze (Init_After, Stat); + end; + end if; - if Present (Alias (Subp)) then - if Is_CPP_Class (Etype (Def_Id)) then - Set_Has_Delayed_Freeze (Subp); + -- Final transformation, if the initializing expression is an entity + -- for a variable with OK_To_Rename set, then we transform: - 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; + -- X : typ := expr; - Next_Elmt (Elmt); - end loop; - end; - end if; + -- into - -- 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). + -- X : typ renames expr - Set_Is_Frozen (Def_Id, False); + -- provided that X is not aliased. The aliased case has to be + -- excluded in general because Expr will not be aliased in general. - -- Do not add the spec of predefined primitives in case of - -- CPP tagged type derivations that have convention CPP. + if Rewrite_As_Renaming then + Rewrite (N, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Defining_Identifier (N), + Subtype_Mark => Obj_Def, + Name => Expr_Q)); - if Is_CPP_Class (Root_Type (Def_Id)) - and then Convention (Def_Id) = Convention_CPP - then - null; + -- We do not analyze this renaming declaration, because all its + -- components have already been analyzed, and if we were to go + -- ahead and analyze it, we would in effect be trying to generate + -- another declaration of X, which won't do. - -- Do not add the spec of the predefined primitives if we are - -- compiling under restriction No_Dispatching_Calls. + Set_Renamed_Object (Defining_Identifier (N), Expr_Q); + Set_Analyzed (N); - 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; + -- We do need to deal with debug issues for this renaming - -- 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. + -- First, if entity comes from source, then mark it as needing + -- debug information, even though it is defined by a generated + -- renaming that does not come from source. - 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); + if Comes_From_Source (Defining_Identifier (N)) then + Set_Debug_Info_Needed (Defining_Identifier (N)); 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. + -- Now call the routine to generate debug info for the renaming - 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; + declare + Decl : constant Node_Id := Debug_Renaming_Declaration (N); + begin + if Present (Decl) then + Insert_Action (N, Decl); + end if; + end; + end if; + 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 Nkind (N) = N_Object_Declaration + and then Nkind (Obj_Def) = N_Access_Definition + and then not Is_Local_Anonymous_Access (Etype (Def_Id)) + then + -- An Ada 2012 stand-alone object of an anonymous access type - -- 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. + declare + Loc : constant Source_Ptr := Sloc (N); - 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; + Level : constant Entity_Id := + Make_Defining_Identifier (Sloc (N), + Chars => + New_External_Name (Chars (Def_Id), Suffix => "L")); - -- Create and decorate the tags. Suppress their creation when - -- not Tagged_Type_Expansion because the dispatching mechanism is - -- handled internally by the virtual target. + Level_Expr : Node_Id; + Level_Decl : Node_Id; - if Tagged_Type_Expansion then - Append_Freeze_Actions (Def_Id, Make_Tags (Def_Id)); + begin + Set_Ekind (Level, Ekind (Def_Id)); + Set_Etype (Level, Standard_Natural); + Set_Scope (Level, Scope (Def_Id)); - -- Generate dispatch table of locally defined tagged type. - -- Dispatch tables of library level tagged types are built - -- later (see Analyze_Declarations). + if No (Expr) then - if not Building_Static_DT (Def_Id) then - Append_Freeze_Actions (Def_Id, Make_DT (Def_Id)); - end if; - end if; + -- Set accessibility level of null - -- If the type has unknown discriminants, propagate dispatching - -- information to its underlying record view, which does not get - -- its own dispatch table. + Level_Expr := + Make_Integer_Literal (Loc, Scope_Depth (Standard_Standard)); - 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; + else + Level_Expr := Dynamic_Accessibility_Level (Expr); 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; + Level_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Level, + Object_Definition => + New_Occurrence_Of (Standard_Natural, Loc), + Expression => Level_Expr, + Constant_Present => Constant_Present (N), + Has_Init_Expression => True); - Append_Freeze_Actions (Def_Id, - Freeze_Entity - (Find_Prim_Op (Def_Id, Name_Initialize), Def_Id)); + Insert_Action_After (Init_After, Level_Decl); - Append_Freeze_Actions (Def_Id, - Freeze_Entity - (Find_Prim_Op (Def_Id, Name_Finalize), Def_Id)); - end if; + Set_Extra_Accessibility (Def_Id, Level); + end; + 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 the object is default initialized and its type is subject to + -- pragma Default_Initial_Condition, add a runtime check to verify + -- the assumption of the pragma (SPARK RM 7.3.3). Generate: - if not Restriction_Active (No_Dispatching_Calls) then - Append_Freeze_Actions - (Def_Id, Predefined_Primitive_Freeze (Def_Id)); - end if; - end if; + -- Default_Init_Cond ( (Def_Id)); - -- 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. + -- Note that the check is generated for source objects only - elsif Has_Discriminants (Def_Id) - and then not Is_Limited_Type (Def_Id) + if Comes_From_Source (Def_Id) + and then (Has_Default_Init_Cond (Typ) + or else + Has_Inherited_Default_Init_Cond (Typ)) + and then not Has_Init_Expression (N) then declare - Comps : constant Node_Id := - Component_List (Type_Definition (Type_Decl)); + DIC_Call : constant Node_Id := + Build_Default_Init_Cond_Call (Loc, Def_Id, Typ); 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) + if Present (Next_N) then + Insert_Before_And_Analyze (Next_N, DIC_Call); - -- 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). + -- The object declaration is the last node in a declarative or a + -- statement list. - 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); + else + Append_To (List_Containing (N), DIC_Call); + Analyze (DIC_Call); + end if; + end; 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. + -- Exception on library entity not available - 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; + exception + when RE_Not_Available => + return; + end Expand_N_Object_Declaration; - 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); + --------------------------------- + -- Expand_N_Subtype_Indication -- + --------------------------------- - Set_Discriminal_Link (Discriminal (Conc_Discr), Conc_Discr); - Set_Discriminal_Link (Discriminal (Rec_Discr), Rec_Discr); + -- Add a check on the range of the subtype. The static case is partially + -- duplicated by Process_Range_Expr_In_Decl in Sem_Ch3, but we still need + -- to check here for the static case in order to avoid generating + -- extraneous expanded code. Also deal with validity checking. - Next_Discriminant (Conc_Discr); - Next_Discriminant (Rec_Discr); - end loop; - end; - end if; + procedure Expand_N_Subtype_Indication (N : Node_Id) is + Ran : constant Node_Id := Range_Expression (Constraint (N)); + Typ : constant Entity_Id := Entity (Subtype_Mark (N)); - if Has_Controlled_Component (Def_Id) then - Build_Controlling_Procs (Def_Id); + begin + if Nkind (Constraint (N)) = N_Range_Constraint then + Validity_Check_Range (Range_Expression (Constraint (N))); end if; - Adjust_Discriminants (Def_Id); + if Nkind_In (Parent (N), N_Constrained_Array_Definition, N_Slice) then + Apply_Range_Check (Ran, Typ); + end if; + end Expand_N_Subtype_Indication; - if Tagged_Type_Expansion or else not Is_Interface (Def_Id) then + --------------------------- + -- Expand_N_Variant_Part -- + --------------------------- - -- Do not need init for interfaces on virtual targets since they're - -- abstract. + -- Note: this procedure no longer has any effect. It used to be that we + -- would replace the choices in the last variant by a when others, and + -- also expanded static predicates in variant choices here, but both of + -- those activities were being done too early, since we can't check the + -- choices until the statically predicated subtypes are frozen, which can + -- happen as late as the free point of the record, and we can't change the + -- last choice to an others before checking the choices, which is now done + -- at the freeze point of the record. - Build_Record_Init_Proc (Type_Decl, Def_Id); - end if; + procedure Expand_N_Variant_Part (N : Node_Id) is + begin + null; + end Expand_N_Variant_Part; - -- 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. + --------------------------------- + -- Expand_Previous_Access_Type -- + --------------------------------- - if Is_Tagged_Type (Def_Id) and then not Is_Interface (Def_Id) then + procedure Expand_Previous_Access_Type (Def_Id : Entity_Id) is + Ptr_Typ : Entity_Id; - -- Do not add the body of predefined primitives in case of CPP tagged - -- type derivations that have convention CPP. + begin + -- Find all access types in the current scope whose designated type is + -- Def_Id and build master renamings for them. - if Is_CPP_Class (Root_Type (Def_Id)) - and then Convention (Def_Id) = Convention_CPP + Ptr_Typ := First_Entity (Current_Scope); + while Present (Ptr_Typ) loop + if Is_Access_Type (Ptr_Typ) + and then Designated_Type (Ptr_Typ) = Def_Id + and then No (Master_Id (Ptr_Typ)) then - null; + -- Ensure that the designated type has a master - -- 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. + Build_Master_Entity (Def_Id); + + -- Private and incomplete types complicate the insertion of master + -- renamings because the access type may precede the full view of + -- the designated type. For this reason, the master renamings are + -- inserted relative to the designated type. + + Build_Master_Renaming (Ptr_Typ, Ins_Nod => Parent (Def_Id)); + end if; - elsif not Restriction_Active (No_Dispatching_Calls) then + Next_Entity (Ptr_Typ); + end loop; + end Expand_Previous_Access_Type; - -- 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. + ----------------------------- + -- Expand_Record_Extension -- + ----------------------------- - Make_Finalize_Address_Body (Def_Id); - Predef_List := Predefined_Primitive_Bodies (Def_Id, Renamed_Eq); - Append_Freeze_Actions (Def_Id, Predef_List); - end if; + -- Add a field _parent at the beginning of the record extension. This is + -- used to implement inheritance. Here are some examples of expansion: - -- Ada 2005 (AI-391): If any wrappers were created for nonoverridden - -- inherited functions, then add their bodies to the freeze actions. + -- 1. no discriminants + -- type T2 is new T1 with null record; + -- gives + -- type T2 is new T1 with record + -- _Parent : T1; + -- end record; - if Present (Wrapper_Body_List) then - Append_Freeze_Actions (Def_Id, Wrapper_Body_List); - end if; + -- 2. renamed discriminants + -- type T2 (B, C : Int) is new T1 (A => B) with record + -- _Parent : T1 (A => B); + -- D : Int; + -- end; - -- 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. + -- 3. inherited discriminants + -- type T2 is new T1 with record -- discriminant A inherited + -- _Parent : T1 (A); + -- D : Int; + -- end; - declare - Elmt : Elmt_Id; - Subp : Entity_Id; + 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 - 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; + 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. - Next_Elmt (Elmt); - end loop; - end; + if not Expander_Active then + return; 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; + -- 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. - Attributes_Set : Boolean := False; - Master_Built : Boolean := False; - -- Two flags which control the creation and initialization of a - -- common heterogeneous master. + if No (Rec_Ext_Part) then + Rec_Ext_Part := + Make_Record_Definition (Loc, + End_Label => Empty, + Component_List => Empty, + Null_Present => True); - begin - Comp := First_Component (Def_Id); - while Present (Comp) loop - Comp_Typ := Etype (Comp); + Set_Record_Extension_Part (Def, Rec_Ext_Part); + Mark_Rewrite_Insertion (Rec_Ext_Part); + end if; - -- A non-self-referential anonymous access-to-controlled - -- component. + Comp_List := Component_List (Rec_Ext_Part); - 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. + Parent_N := Make_Defining_Identifier (Loc, Name_uParent); - if not Master_Built then - Master_Built := True; + -- If the derived type inherits its discriminants the type of the + -- _parent field must be constrained by the inherited discriminants - -- 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"). + 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; - Set_Associated_Storage_Pool - (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object)); + 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); - Build_Finalization_Master - (Typ => Root_Type (Comp_Typ), - For_Anonymous => True, - Context_Scope => Encl_Scope, - Insertion_Node => Ins_Node); + -- Otherwise the original subtype_indication is just what is needed - Fin_Mas_Id := Finalization_Master (Comp_Typ); + else + Par_Subtype := Process_Subtype (New_Copy_Tree (Indic), Def); + end if; - -- Subsequent anonymous access-to-controlled components - -- reuse the available master. + Set_Parent_Subtype (T, Par_Subtype); - 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"). + 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))); - Set_Associated_Storage_Pool - (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object)); + 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); - -- Shared the master among multiple components + 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); - Set_Finalization_Master - (Root_Type (Comp_Typ), Fin_Mas_Id); + else + Insert_Before (First (Component_Items (Comp_List)), Comp_Decl); + end if; - -- Convert the master into a heterogeneous collection. - -- Generate: - -- Set_Is_Heterogeneous (); + Analyze (Comp_Decl); + end Expand_Record_Extension; - if not Attributes_Set then - Attributes_Set := True; + ------------------------ + -- Expand_Tagged_Root -- + ------------------------ - 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; + procedure Expand_Tagged_Root (T : Entity_Id) is + Def : constant Node_Id := Type_Definition (Parent (T)); + Comp_List : Node_Id; + Comp_Decl : Node_Id; + Sloc_N : Source_Ptr; - Next_Component (Comp); - end loop; - end; + begin + if Null_Present (Def) then + Set_Component_List (Def, + Make_Component_List (Sloc (Def), + Component_Items => Empty_List, + Variant_Part => Empty, + Null_Present => True)); end if; - -- Check whether individual components have a defined invariant, and add - -- the corresponding component invariant checks. + Comp_List := Component_List (Def); - -- 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. + if Null_Present (Comp_List) + or else Is_Empty_List (Component_Items (Comp_List)) + then + Sloc_N := Sloc (Comp_List); + else + Sloc_N := Sloc (First (Component_Items (Comp_List))); + end if; - -- Such objects will show up in a class-wide postcondition, and the - -- invariant will be checked, if necessary, upon return from the - -- enclosing subprogram. + Comp_Decl := + Make_Component_Declaration (Sloc_N, + Defining_Identifier => First_Tag_Component (T), + Component_Definition => + Make_Component_Definition (Sloc_N, + Aliased_Present => False, + Subtype_Indication => New_Occurrence_Of (RTE (RE_Tag), Sloc_N))); - if not Is_Class_Wide_Equivalent_Type (Def_Id) then - Insert_Component_Invariant_Checks - (N, Def_Id, Build_Record_Invariant_Proc (Def_Id, N)); + if 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; - end Expand_Freeze_Record_Type; + + -- We don't Analyze the whole expansion because the tag component has + -- already been analyzed previously. Here we just insure that the tree + -- is coherent with the semantic decoration + + Find_Type (Subtype_Indication (Component_Definition (Comp_Decl))); + + exception + when RE_Not_Available => + return; + end Expand_Tagged_Root; ------------------------------ -- 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. - - 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. + -- 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. - 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)) -- 2.30.2