From 65356e64cf0fc85effb4b77d9e253c7d28bf407c Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 14 Nov 2003 11:24:47 +0100 Subject: [multiple changes] 2003-11-13 Vincent Celier * 5bml-tgt.adb (Build_Dynamic_Library): Use Osint.Include_Dir_Default_Prefix instead of Sdefault.Include_Dir_Default_Name. * gnatlbr.adb: Update Copyright notice (Gnatlbr): : Use Osint.Include_Dir_Default_Prefix instead of Sdefault.Include_Dir_Default_Name and Osint.Object_Dir_Default_Prefix instead of Sdefault.Object_Dir_Default_Name * gnatlink.adb: (Process_Binder_File): Never suppress the option following -Xlinker * mdll-utl.adb: (Gcc): Use Osint.Object_Dir_Default_Prefix instead of Sdefault.Object_Dir_Default_Name. * osint.ads, osint.adb: (Include_Dir_Default_Prefix, Object_Dir_Default_Prefix): New functions Minor reformatting. * vms_conv.ads: Minor reformating Remove GNAT STANDARD and GNAT PSTA * vms_conv.adb: Allow GNAT MAKE to have several files on the command line. (Init_Object_Dirs): Use Osint.Object_Dir_Default_Prefix instead of Sdefault.Object_Dir_Default_Name. Minor Reformating Remove data for GNAT STANDARD * vms_data.ads: Add new compiler qualifier /PRINT_STANDARD (-gnatS) Remove data for GNAT STANDARD Remove options and documentation for -gnatwb/-gnatwB: these warning options no longer exist. 2003-11-13 Ed Falis * 5zthrini.adb: (Init_RTS): Made visible * 5zthrini.adb: (Register): Removed unnecessary call to taskVarGet that checked whether an ATSD was already set as a task var for the argument thread. * s-thread.adb: Updated comment to reflect that this is a VxWorks version Added context clause for System.Threads.Initialization Added call to System.Threads.Initialization.Init_RTS 2003-11-13 Jerome Guitton * 5zthrini.adb: (Init_RTS): New procedure, for the initialization of the run-time lib. * s-thread.adb: Remove dependancy on System.Init, so that this file can be used in the AE653 sequential run-time lib. 2003-11-13 Robert Dewar * bindgen.adb: Minor reformatting 2003-11-13 Ed Schonberg * checks.adb: (Apply_Discriminant_Check): Do no apply check if target type is derived from source type with no applicable constraint. * lib-writ.adb: (Ensure_System_Dependency): Do not apply the style checks that may have been specified for the main unit. * sem_ch8.adb: (Find_Selected_Component): Further improvement in error message, with RM reference. * sem_res.adb: (Resolve): Handle properly the case of an illegal overloaded protected procedure. 2003-11-13 Javier Miranda * exp_aggr.adb: (Has_Default_Init_Comps): New function to check the presence of default initialization in an aggregate. (Build_Record_Aggr_Code): Recursively expand the ancestor in case of extension aggregate of a limited record. In addition, a new formal was added to do not initialize the record controller (if any) during this recursive expansion of ancestors. (Init_Controller): Add support for limited record components. (Expand_Record_Aggregate): In case of default initialized components convert the aggregate into a set of assignments. * par-ch4.adb (P_Aggregate_Or_Paren_Expr): Update the comment describing the new syntax. Nothing else needed to be done because this subprogram delegates part of its work to P_Precord_Or_Array_Component_Association. (P_Record_Or_Array_Component_Association): Give support to the new syntax for default initialization of components. * sem_aggr.adb: (Resolve_Aggregate): Relax the strictness of the frontend in case of limited aggregates. (Resolve_Record_Aggregate): Give support to default initialized components. (Get_Value): In case of default initialized components, duplicate the corresponding default expression (from the record type declaration). In case of default initialization in the *others* choice, do not check that all components have the same type. (Resolve_Extension_Aggregate): Give support to limited extension aggregates. * sem_ch3.adb: (Check_Initialization): Relax the strictness of the front-end in case of aggregate and extension aggregates. This test is now done in Get_Value in a per-component manner. * sem_ch4.adb (Analyze_Allocator): Don't post an error if the expression corresponds to a limited aggregate. This test is now done in Get_Value. * sinfo.ads, sinfo.adb (N_Component_Association): Addition of Box_Present flag. * sprint.adb (Sprint_Node_Actual): Modified to print an mbox if present in an N_Component_Association node 2003-11-13 Thomas Quinot * sem_ch9.adb (Analyze_Accept_Statement): A procedure hides a type-conformant entry only if they are homographs. 2003-11-13 GNAT Script * Make-lang.in: Makefile automatically updated From-SVN: r73596 --- gcc/ada/exp_aggr.adb | 153 ++++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 127 insertions(+), 26 deletions(-) (limited to 'gcc/ada/exp_aggr.adb') diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 0985ead..e2413bb 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -70,6 +70,10 @@ package body Exp_Aggr is -- statement of variant part will usually be small and probably in near -- sorted order. + function Has_Default_Init_Comps (N : Node_Id) return Boolean; + -- N is an aggregate (record or array). Checks the presence of + -- default initialization (<>) in any component. + ------------------------------------------------------ -- Local subprograms for Record Aggregate Expansion -- ------------------------------------------------------ @@ -97,12 +101,13 @@ package body Exp_Aggr is -- assignments component per component. function Build_Record_Aggr_Code - (N : Node_Id; - Typ : Entity_Id; - Target : Node_Id; - Flist : Node_Id := Empty; - Obj : Entity_Id := Empty) - return List_Id; + (N : Node_Id; + Typ : Entity_Id; + Target : Node_Id; + Flist : Node_Id := Empty; + Obj : Entity_Id := Empty; + Is_Limited_Ancestor_Expansion : Boolean := False) + return List_Id; -- N is an N_Aggregate or a N_Extension_Aggregate. Typ is the type -- of the aggregate. Target is an expression containing the -- location on which the component by component assignments will @@ -113,6 +118,8 @@ package body Exp_Aggr is -- object declaration and dynamic allocation cases, it contains -- an entity that allows to know if the value being created needs to be -- attached to the final list in case of pragma finalize_Storage_Only. + -- Is_Limited_Ancestor_Expansion indicates that the function has been + -- called recursively to expand the limited ancestor to avoid copying it. function Has_Mutable_Components (Typ : Entity_Id) return Boolean; -- Return true if one of the component is of a discriminated type with @@ -1269,12 +1276,13 @@ package body Exp_Aggr is ---------------------------- function Build_Record_Aggr_Code - (N : Node_Id; - Typ : Entity_Id; - Target : Node_Id; - Flist : Node_Id := Empty; - Obj : Entity_Id := Empty) - return List_Id + (N : Node_Id; + Typ : Entity_Id; + Target : Node_Id; + Flist : Node_Id := Empty; + Obj : Entity_Id := Empty; + Is_Limited_Ancestor_Expansion : Boolean := False) + return List_Id is Loc : constant Source_Ptr := Sloc (N); L : constant List_Id := New_List; @@ -1540,20 +1548,50 @@ package body Exp_Aggr is Selector_Name => Make_Identifier (Loc, Name_uController)); Set_Assignment_OK (Ref); - if Init_Pr then - Append_List_To (L, - Build_Initialization_Call (Loc, - Id_Ref => Ref, - Typ => RTE (RE_Record_Controller), - In_Init_Proc => Within_Init_Proc)); - end if; + -- Give support to default initialization of limited types and + -- components - Append_To (L, - Make_Procedure_Call_Statement (Loc, - Name => - New_Reference_To (Find_Prim_Op (RTE (RE_Record_Controller), - Name_Initialize), Loc), - Parameter_Associations => New_List (New_Copy_Tree (Ref)))); + if (Nkind (Target) = N_Identifier + and then Is_Limited_Type (Etype (Target))) + or else (Nkind (Target) = N_Selected_Component + and then Is_Limited_Type (Etype (Selector_Name (Target)))) + or else (Nkind (Target) = N_Unchecked_Type_Conversion + and then Is_Limited_Type (Etype (Target))) + then + + if Init_Pr then + Append_List_To (L, + Build_Initialization_Call (Loc, + Id_Ref => Ref, + Typ => RTE (RE_Limited_Record_Controller), + In_Init_Proc => Within_Init_Proc)); + end if; + + Append_To (L, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To + (Find_Prim_Op (RTE (RE_Limited_Record_Controller), + Name_Initialize), Loc), + Parameter_Associations => New_List (New_Copy_Tree (Ref)))); + + else + if Init_Pr then + Append_List_To (L, + Build_Initialization_Call (Loc, + Id_Ref => Ref, + Typ => RTE (RE_Record_Controller), + In_Init_Proc => Within_Init_Proc)); + end if; + + Append_To (L, + Make_Procedure_Call_Statement (Loc, + Name => + New_Reference_To (Find_Prim_Op (RTE (RE_Record_Controller), + Name_Initialize), Loc), + Parameter_Associations => New_List (New_Copy_Tree (Ref)))); + + end if; Append_To (L, Make_Attach_Call ( @@ -1648,6 +1686,21 @@ package body Exp_Aggr is Check_Ancestor_Discriminants (Entity (A)); end if; + -- If the ancestor part is a limited type, a recursive call + -- expands the ancestor. + + elsif Is_Limited_Type (Etype (A)) then + Ancestor_Is_Expression := True; + + Append_List_To (Start_L, + Build_Record_Aggr_Code ( + N => Expression (A), + Typ => Etype (Expression (A)), + Target => Target, + Flist => Flist, + Obj => Obj, + Is_Limited_Ancestor_Expansion => True)); + -- If the ancestor part is an expression "E", we generate -- T(tmp) := E; @@ -1767,6 +1820,22 @@ package body Exp_Aggr is while Present (Comp) loop Selector := Entity (First (Choices (Comp))); + -- Default initialization of a limited component + + if Box_Present (Comp) + and then Is_Limited_Type (Etype (Selector)) + then + Append_List_To (L, + Build_Initialization_Call (Loc, + Id_Ref => Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => New_Occurrence_Of (Selector, + Loc)), + Typ => Etype (Selector))); + + goto Next_Comp; + end if; + -- ??? if Ekind (Selector) /= E_Discriminant @@ -1900,6 +1969,8 @@ package body Exp_Aggr is end; end if; + <> + Next (Comp); end loop; @@ -1997,7 +2068,9 @@ package body Exp_Aggr is -- In the Has_Controlled component case, all the intermediate -- controllers must be initialized - if Has_Controlled_Component (Typ) then + if Has_Controlled_Component (Typ) + and not Is_Limited_Ancestor_Expansion + then declare Inner_Typ : Entity_Id; Outer_Typ : Entity_Id; @@ -4082,6 +4155,9 @@ package body Exp_Aggr is then Convert_To_Assignments (N, Typ); + elsif Has_Default_Init_Comps (N) then + Convert_To_Assignments (N, Typ); + elsif Has_Delayed_Nested_Aggregate_Or_Tagged_Comps then Convert_To_Assignments (N, Typ); @@ -4402,6 +4478,31 @@ package body Exp_Aggr is end if; end Expand_Record_Aggregate; + ---------------------------- + -- Has_Default_Init_Comps -- + ---------------------------- + + function Has_Default_Init_Comps (N : Node_Id) return Boolean is + Comps : constant List_Id := Component_Associations (N); + C : Node_Id; + begin + pragma Assert (Nkind (N) = N_Aggregate + or else Nkind (N) = N_Extension_Aggregate); + if No (Comps) then + return False; + end if; + + C := First (Comps); + while Present (C) loop + if Box_Present (C) then + return True; + end if; + + Next (C); + end loop; + return False; + end Has_Default_Init_Comps; + -------------------------- -- Is_Delayed_Aggregate -- -------------------------- -- cgit v1.1