diff options
| -rw-r--r-- | gcc/ada/ali.adb | 21 | ||||
| -rw-r--r-- | gcc/ada/ali.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/binde.adb | 63 | ||||
| -rw-r--r-- | gcc/ada/debug.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/lib-writ.adb | 38 | ||||
| -rw-r--r-- | gcc/ada/lib-writ.ads | 14 | ||||
| -rw-r--r-- | gcc/ada/sem_elab.adb | 220 | ||||
| -rw-r--r-- | gcc/ada/sinfo.adb | 52 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 122 |
9 files changed, 432 insertions, 123 deletions
diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index c1ea6c46930..2bafec0295d 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, 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- -- @@ -1556,6 +1556,7 @@ package body ALI is Withs.Table (Withs.Last).Uname := Get_Name; Withs.Table (Withs.Last).Elaborate := False; Withs.Table (Withs.Last).Elaborate_All := False; + Withs.Table (Withs.Last).Elab_Desirable := False; Withs.Table (Withs.Last).Elab_All_Desirable := False; Withs.Table (Withs.Last).SAL_Interface := False; @@ -1571,12 +1572,24 @@ package body ALI is Withs.Table (Withs.Last).Sfile := Get_Name (Lower => True); Withs.Table (Withs.Last).Afile := Get_Name; - -- Scan out possible E, EA, and NE parameters + -- Scan out possible E, EA, ED, and AD parameters while not At_Eol loop Skip_Space; - if Nextc = 'E' then + if Nextc = 'A' then + P := P + 1; + Checkc ('D'); + Check_At_End_Of_Field; + + -- Store AD indication unless ignore required + + if not Ignore_ED then + Withs.Table (Withs.Last).Elab_All_Desirable := + True; + end if; + + elsif Nextc = 'E' then P := P + 1; if At_End_Of_Field then @@ -1594,7 +1607,7 @@ package body ALI is -- Store ED indication unless ignore required if not Ignore_ED then - Withs.Table (Withs.Last).Elab_All_Desirable := + Withs.Table (Withs.Last).Elab_Desirable := True; end if; end if; diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads index 6582a1a19bc..f00220f59e6 100644 --- a/gcc/ada/ali.ads +++ b/gcc/ada/ali.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, 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- -- @@ -473,6 +473,9 @@ package ALI is -- Indicates presence of EA parameter Elab_All_Desirable : Boolean; + -- Indicates presence of AD parameter + + Elab_Desirable : Boolean; -- Indicates presence of ED parameter SAL_Interface : Boolean := False; @@ -872,7 +875,7 @@ package ALI is -- switch description settings. -- -- Ignore_ED is normally False. If set to True, it indicates that - -- all ED (elaboration desirable) indications in the ALI file are + -- all AD/ED (elaboration desirable) indications in the ALI file are -- to be ignored. This parameter is obsolete now that the -f switch -- is removed from gnatbind, and should be removed ??? -- diff --git a/gcc/ada/binde.adb b/gcc/ada/binde.adb index 2985b90b9e9..acba7846418 100644 --- a/gcc/ada/binde.adb +++ b/gcc/ada/binde.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, 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- -- @@ -72,11 +72,16 @@ package body Binde is -- elaborated before unit X is elaborated. The Elab_All_Link list -- traces the dependencies in the latter case. - Elab_Desirable, + Elab_All_Desirable, -- This is just like Elab_All, except that the elaborate all was not -- explicitly present in the source, but rather was created by the -- front end, which decided that it was "desirable". + Elab_Desirable, + -- This is just like Elab, except that the elaborate was not + -- explicitly present in the source, but rather was created by the + -- front end, which decided that it was "desirable". + Spec_First); -- After is a body, and Before is the corresponding spec @@ -249,7 +254,7 @@ package body Binde is Link : Elab_All_Id); -- Used to compute the transitive closure of elaboration links for an -- Elaborate_All pragma (Reason = Elab_All) or for an indication of - -- Elaborate_All_Desirable (Reason = Elab_Desirable). Unit After has + -- Elaborate_All_Desirable (Reason = Elab_All_Desirable). Unit After has -- a pragma Elaborate_All or the front end has determined that a reference -- probably requires Elaborate_All is required, and unit Before must be -- previously elaborated. First a link is built making sure that unit @@ -268,8 +273,7 @@ package body Binde is function Make_Elab_Entry (Unam : Unit_Name_Type; - Link : Elab_All_Id) - return Elab_All_Id; + Link : Elab_All_Id) return Elab_All_Id; -- Make an Elab_All_Entries table entry with the given Unam and Link function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id; @@ -800,9 +804,9 @@ package body Binde is SL : Successor_Link renames Succ.Table (S); begin - -- Nothing to do if internal unit involved and no -de flag + -- Nothing to do if internal unit involved and no -da flag - if not Debug_Flag_E + if not Debug_Flag_A and then (Is_Internal_File_Name (Units.Table (SL.Before).Sfile) or else @@ -841,7 +845,7 @@ package body Binde is (" reason: pragma Elaborate_All in unit &", Info => True); - when Elab_Desirable => + when Elab_All_Desirable => Error_Msg_Output (" reason: implicit Elaborate_All in unit &", Info => True); @@ -850,6 +854,15 @@ package body Binde is (" recompile & with -gnatwl for full details", Info => True); + when Elab_Desirable => + Error_Msg_Output + (" reason: implicit Elaborate in unit &", + Info => True); + + Error_Msg_Output + (" recompile & with -gnatwl for full details", + Info => True); + when Spec_First => Error_Msg_Output (" reason: spec always elaborated before body", @@ -1092,7 +1105,7 @@ package body Binde is -- Now establish all the links we need Elab_All_Links - (Withed_Unit, U, Elab_Desirable, + (Withed_Unit, U, Elab_All_Desirable, Make_Elab_Entry (Withs.Table (W).Uname, No_Elab_All_Link)); @@ -1116,6 +1129,18 @@ package body Binde is (Corresponding_Body (Withed_Unit), U, Elab); end if; + -- Elaborate_Desirable case, for this we establish + -- the same links as above, but with a different reason. + + elsif Withs.Table (W).Elab_Desirable then + Build_Link (Withed_Unit, U, Withed); + + if Units.Table (Withed_Unit).Utype = Is_Spec then + Build_Link + (Corresponding_Body (Withed_Unit), + U, Elab_Desirable); + end if; + -- Case of normal WITH with no elaboration pragmas, just -- build the single link to the directly referenced unit @@ -1137,8 +1162,7 @@ package body Binde is function Make_Elab_Entry (Unam : Unit_Name_Type; - Link : Elab_All_Id) - return Elab_All_Id + Link : Elab_All_Id) return Elab_All_Id is begin Elab_All_Entries.Increment_Last; @@ -1153,7 +1177,6 @@ package body Binde is function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is Info : constant Int := Get_Name_Table_Info (Uname); - begin pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id); return Unit_Id (Info); @@ -1172,12 +1195,20 @@ package body Binde is -- Determines if U is a waiting body, defined as a body which has -- not been elaborated, but whose spec has been elaborated. + --------------- + -- Body_Unit -- + --------------- + function Body_Unit (U : Unit_Id) return Boolean is begin return Units.Table (U).Utype = Is_Body or else Units.Table (U).Utype = Is_Body_Only; end Body_Unit; + ------------------ + -- Waiting_Body -- + ------------------ + function Waiting_Body (U : Unit_Id) return Boolean is begin return Units.Table (U).Utype = Is_Body and then @@ -1186,10 +1217,10 @@ package body Binde is -- Start of processing for Worse_Choice - -- Note: the checks here are applied in sequence, and the ordering is - -- significant (i.e. the more important criteria are applied first). - begin + -- Note: the checks here are applied in sequence, and the ordering is + -- significant (i.e. the more important criteria are applied first). + -- If either unit is internal, then use Better_Choice, since the -- language requires that predefined units not mess up in the choice -- of elaboration order, and for internal units, any problems are @@ -1277,7 +1308,7 @@ package body Binde is First_Name : Boolean := True; begin - if ST.Reason in Elab_All .. Elab_Desirable then + if ST.Reason in Elab_All .. Elab_All_Desirable then L := ST.Elab_All_Link; while L /= No_Elab_All_Link loop Nam := Elab_All_Entries.Table (L).Needed_By; diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 2fd5b25c673..96e9ca74e7b 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, 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- -- @@ -98,7 +98,7 @@ package body Debug is -- d.c -- d.d -- d.e - -- d.f + -- d.f Inhibit folding of static expressions -- d.g -- d.h -- d.i @@ -132,7 +132,7 @@ package body Debug is -- Debug flags for binder (GNATBIND) - -- da + -- da All links (including internal units) listed if there is a cycle -- db -- dc List units as they are chosen -- dd @@ -410,7 +410,7 @@ package body Debug is -- indications. This debug flag disconnects the tracking of constant -- values (see Exp_Ch2.Expand_Current_Value). - -- dN Do not generate file name information in exception messages. + -- dN Do not generate file name information in exception messages -- dO Output immediate error messages. This causes error messages to -- be output as soon as they are generated (disconnecting several @@ -461,6 +461,10 @@ package body Debug is -- had Configurable_Run_Time_Mode set to True. This is useful in -- testing high integrity mode. + -- d.f Suppress folding of static expressions. This of course results + -- in seriously non-conforming behavior, but is useful sometimes + -- when tracking down handling of complex expressions. + -- d.x No exception handlers in generated code. This causes exception -- handlers to be eliminated from the generated code. They are still -- fully compiled and analyzed, they just get eliminated from the @@ -511,6 +515,12 @@ package body Debug is -- Documentation for Binder Debug Flags -- ------------------------------------------ + -- da Normally if there is an elaboration circularity, then in describing + -- the cycle, links involving internal units are omitted, since they + -- are irrelevant and confusing. This debug flag causes all links to + -- be listed, and is useful when diagnosing circularities introduced + -- by incorrect changes to the run-time library itself. + -- dc List units as they are chosen. As units are selected for addition to -- the elaboration order, a line of output is generated showing which -- unit has been selected. diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 76952b5ac72..e8065b46aad 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, 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- -- @@ -182,6 +182,9 @@ package body Lib.Writ is -- Array of flags to show which units have pragma Elaborate All set Elab_Des_Flags : array (Units.First .. Last_Unit) of Boolean; + -- Array of flags to show which units have Elaborate_Desirable set + + Elab_All_Des_Flags : array (Units.First .. Last_Unit) of Boolean; -- Array of flags to show which units have Elaborate_All_Desirable set Sdep_Table : Unit_Ref_Table (1 .. Pos (Last_Unit - Units.First + 2)); @@ -229,11 +232,13 @@ package body Lib.Writ is Item := First (Context_Items (Cunit)); while Present (Item) loop + -- Process with clause + -- Ada 2005 (AI-50217): limited with_clauses do not create -- dependencies if Nkind (Item) = N_With_Clause - and then not (Limited_Present (Item)) + and then not (Limited_Present (Item)) then Unum := Get_Cunit_Unit_Number (Library_Unit (Item)); With_Flags (Unum) := True; @@ -246,7 +251,11 @@ package body Lib.Writ is Elab_All_Flags (Unum) := True; end if; - if Elaborate_All_Desirable (Cunit_Entity (Unum)) then + if Elaborate_All_Desirable (Item) then + Elab_All_Des_Flags (Unum) := True; + end if; + + if Elaborate_Desirable (Item) then Elab_Des_Flags (Unum) := True; end if; end if; @@ -495,10 +504,11 @@ package body Lib.Writ is -- Generate with lines, first those that are directly with'ed for J in With_Flags'Range loop - With_Flags (J) := False; - Elab_Flags (J) := False; - Elab_All_Flags (J) := False; - Elab_Des_Flags (J) := False; + With_Flags (J) := False; + Elab_Flags (J) := False; + Elab_All_Flags (J) := False; + Elab_Des_Flags (J) := False; + Elab_All_Des_Flags (J) := False; end loop; Collect_Withs (Unode); @@ -725,6 +735,10 @@ package body Lib.Writ is if Elab_Des_Flags (Unum) then Write_Info_Str (" ED"); end if; + + if Elab_All_Des_Flags (Unum) then + Write_Info_Str (" AD"); + end if; end if; Write_Info_EOL; @@ -818,12 +832,10 @@ package body Lib.Writ is begin if Nkind (U) = N_Subprogram_Body - or else (Nkind (U) = N_Package_Body - and then - (Nkind (Original_Node (U)) = N_Function_Instantiation - or else - Nkind (Original_Node (U)) = - N_Procedure_Instantiation)) + or else + (Nkind (U) = N_Package_Body + and then + Nkind (Original_Node (U)) in N_Subprogram_Instantiation) then -- If the unit is a subprogram instance, the entity for the -- subprogram is the alias of the visible entity, which is the diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads index 38124789187..90737ed1268 100644 --- a/gcc/ada/lib-writ.ads +++ b/gcc/ada/lib-writ.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, 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- -- @@ -462,7 +462,7 @@ package Lib.Writ is -- Following each U line, is a series of lines of the form - -- W unit-name [source-name lib-name] [E] [EA] [ED] + -- W unit-name [source-name lib-name] [E] [EA] [ED] [AD] -- -- One of these lines is present for each unit that is mentioned in -- an explicit with clause by the current unit. The first parameter @@ -479,11 +479,17 @@ package Lib.Writ is -- -- EA pragma Elaborate_All applies to this unit -- - -- ED Elaborate_All_Desirable set for this unit, which means + -- ED Elaborate_Desirable set for this unit, which means + -- that there is no Elaborate, but the analysis suggests + -- that Program_Error may be raised if the Elaborate + -- conditions cannot be satisfied. The binder will attempt + -- to treat ED as E if it can. + -- + -- AD Elaborate_All_Desirable set for this unit, which means -- that there is no Elaborate_All, but the analysis suggests -- that Program_Error may be raised if the Elaborate_All -- conditions cannot be satisfied. The binder will attempt - -- to treat ED as EA if it can. + -- to treat AD as EA if it can. -- -- The parameter source-name and lib-name are omitted for the case -- of a generic unit compiled with earlier versions of GNAT which diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 25b5fd36624..1eae58685b4 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2005, 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- -- @@ -117,7 +117,6 @@ package body Sem_Elab is Outer_Scope : Entity_Id; -- Save scope of outer level call - end record; package Delay_Check is new Table.Table ( @@ -166,6 +165,13 @@ package body Sem_Elab is -- then the original call was an inner call, and we are not interested -- in calls that go outside this scope. + procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id); + -- Analysis of construct N shows that we should set Elaborate_All_Desirable + -- for the WITH clause for unit U (which will always be present). A special + -- case is when N is a function or procedure instantiation, in which case + -- it is sufficient to set Elaborate_Desirable, since in this case there is + -- no possibility of transitive elaboration issues. + procedure Check_A_Call (N : Node_Id; E : Entity_Id; @@ -308,6 +314,113 @@ package body Sem_Elab is -- which the pragma applies. This prevents spurious warnings when the -- called entity is renamed within U. + -------------------------------------- + -- Activate_Elaborate_All_Desirable -- + -------------------------------------- + + procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id) is + UN : constant Unit_Number_Type := Get_Code_Unit (N); + CU : constant Node_Id := Cunit (UN); + UE : constant Entity_Id := Cunit_Entity (UN); + Unm : constant Unit_Name_Type := Unit_Name (UN); + CI : constant List_Id := Context_Items (CU); + Itm : Node_Id; + Ent : Entity_Id; + + procedure Set_Elab_Flag (Itm : Node_Id); + -- Sets Elaborate_[All_]Desirable as appropriate on Itm + + ------------------- + -- Set_Elab_Flag -- + ------------------- + + procedure Set_Elab_Flag (Itm : Node_Id) is + begin + if Nkind (N) in N_Subprogram_Instantiation then + Set_Elaborate_Desirable (Itm); + else + Set_Elaborate_All_Desirable (Itm); + end if; + end Set_Elab_Flag; + + -- Start of processing for Activate_Elaborate_All_Desirable + + begin + Itm := First (CI); + while Present (Itm) loop + if Nkind (Itm) = N_With_Clause then + Ent := Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm))); + + -- If we find it, then mark elaborate all desirable and return + + if U = Ent then + Set_Elab_Flag (Itm); + return; + end if; + end if; + + Next (Itm); + end loop; + + -- If we fall through then the with clause is not present in the + -- current unit. One legitimate possibility is that the with clause + -- is present in the spec when we are a body. + + if Is_Body_Name (Unm) then + declare + UEs : constant Entity_Id := Spec_Entity (UE); + UNs : constant Unit_Number_Type := Get_Source_Unit (UEs); + CUs : constant Node_Id := Cunit (UNs); + CIs : constant List_Id := Context_Items (CUs); + + begin + Itm := First (CIs); + while Present (Itm) loop + if Nkind (Itm) = N_With_Clause then + Ent := + Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm))); + + if U = Ent then + + -- If we find it, we have to create an implicit copy + -- of the with clause for the body, just so that it + -- can be marked as elaborate desirable (it would be + -- wrong to put it on the spec item, since it is the + -- body that has possible elaboration problems, not + -- the spec. + + declare + CW : constant Node_Id := + Make_With_Clause (Sloc (Itm), + Name => Name (Itm)); + + begin + Set_Library_Unit (CW, Library_Unit (Itm)); + Set_Implicit_With (CW, True); + + -- Set elaborate all desirable on copy and then + -- append the copy to the list of body with's + -- and we are done. + + Set_Elab_Flag (CW); + Append_To (CI, CW); + return; + end; + end if; + end if; + + Next (Itm); + end loop; + end; + end if; + + -- Here if we do not find with clause on spec or body. We just ignore + -- this case, it means that the elaboration involves some other unit + -- than the unit being compiled, and will be caught elsewhere. + + null; + end Activate_Elaborate_All_Desirable; + ------------------ -- Check_A_Call -- ------------------ @@ -370,7 +483,7 @@ package body Sem_Elab is if (Nkind (N) = N_Function_Call or else Nkind (N) = N_Procedure_Call_Statement) - and then No_Elaboration_Check (N) + and then No_Elaboration_Check (N) then return; end if; @@ -710,8 +823,15 @@ package body Sem_Elab is end if; Error_Msg_Qual_Level := Nat'Last; - Error_Msg_NE - ("\missing pragma Elaborate_All for&?", N, W_Scope); + + if Nkind (N) in N_Subprogram_Instantiation then + Error_Msg_NE + ("\missing pragma Elaborate for&?", N, W_Scope); + else + Error_Msg_NE + ("\missing pragma Elaborate_All for&?", N, W_Scope); + end if; + Error_Msg_Qual_Level := 0; Output_Calls (N); @@ -893,7 +1013,6 @@ package body Sem_Elab is ("\?Program_Error will be raised at run time", N); Insert_Elab_Check (N); Set_ABE_Is_Certain (N); - end Check_Bad_Instantiation; --------------------- @@ -1110,13 +1229,19 @@ package body Sem_Elab is return; end if; - if Nkind (P) = N_Subprogram_Body - or else - Nkind (P) = N_Protected_Body + -- A protected body has no elaboration code and contains + -- only other bodies. + + if Nkind (P) = N_Protected_Body then + return; + + elsif Nkind (P) = N_Subprogram_Body or else Nkind (P) = N_Task_Body or else Nkind (P) = N_Block_Statement + or else + Nkind (P) = N_Entry_Body then if L = Declarations (P) then exit; @@ -1510,7 +1635,6 @@ package body Sem_Elab is else Check_Internal_Call_Continue (N, E, Outer_Scope, Orig_Ent); end if; - end Check_Internal_Call; ---------------------------------- @@ -1661,9 +1785,9 @@ package body Sem_Elab is -- does not normally visit subprogram bodies. declare - Decl : Node_Id := First (Declarations (Sbody)); - + Decl : Node_Id; begin + Decl := First (Declarations (Sbody)); while Present (Decl) loop Traverse (Decl); Next (Decl); @@ -1830,7 +1954,6 @@ package body Sem_Elab is and then Has_Task (Base_Type (Typ)) then Comp := First_Component (Typ); - while Present (Comp) loop Add_Task_Proc (Etype (Comp)); Comp := Next_Component (Comp); @@ -1874,10 +1997,9 @@ package body Sem_Elab is end if; else - Elmt := First_Elmt (Inter_Procs); - -- No need for multiple entries of the same type + Elmt := First_Elmt (Inter_Procs); while Present (Elmt) loop if Node (Elmt) = Proc then return; @@ -1899,9 +2021,7 @@ package body Sem_Elab is begin if Present (Decls) then Decl := First (Decls); - while Present (Decl) loop - if Nkind (Decl) = N_Object_Declaration and then Has_Task (Etype (Defining_Identifier (Decl))) then @@ -1918,9 +2038,10 @@ package body Sem_Elab is ---------------- function Outer_Unit (E : Entity_Id) return Entity_Id is - Outer : Entity_Id := E; + Outer : Entity_Id; begin + Outer := E; while Present (Outer) loop if Elaboration_Checks_Suppressed (Outer) then Cunit_SC := True; @@ -1970,7 +2091,6 @@ package body Sem_Elab is -- the task body to be elaborated before the current one. Elmt := First_Elmt (Inter_Procs); - while Present (Elmt) loop Ent := Node (Elmt); Task_Scope := Outer_Unit (Scope (Ent)); @@ -2014,7 +2134,7 @@ package body Sem_Elab is " requires pragma Elaborate_All on &?", N, Ent); end if; - Set_Elaborate_All_Desirable (Task_Scope); + Activate_Elaborate_All_Desirable (N, Task_Scope); Set_Suppress_Elaboration_Warnings (Task_Scope); end if; @@ -2025,8 +2145,8 @@ package body Sem_Elab is -- the task procedure bodies, which are available. In_Task_Activation := True; - Elmt := First_Elmt (Intra_Procs); + Elmt := First_Elmt (Intra_Procs); while Present (Elmt) loop Ent := Node (Elmt); Check_Internal_Call_Continue (N, Ent, Enclosing, Ent); @@ -2060,7 +2180,7 @@ package body Sem_Elab is or else (Is_Child_Unit (Scop) and then Is_Visible_Child_Unit (Scop)) then - Set_Elaborate_All_Desirable (Scop); + Activate_Elaborate_All_Desirable (Call, Scop); Set_Suppress_Elaboration_Warnings (Scop, True); return; end if; @@ -2077,13 +2197,14 @@ package body Sem_Elab is null; -- detailed processing follows. else - Set_Elaborate_All_Desirable (Scop); + Activate_Elaborate_All_Desirable (Call, Scop); Set_Suppress_Elaboration_Warnings (Scop, True); return; end if; -- If the unit is not in the context, there must be an intermediate - -- unit that is, on which we need to place to elaboration flag. + -- unit that is, on which we need to place to elaboration flag. This + -- happens with init proc calls. if Is_Init_Proc (Subp) or else Init_Call @@ -2098,22 +2219,22 @@ package body Sem_Elab is Etype (First (Parameter_Associations (Call))); begin Elab_Unit := Scope (Typ); - while (Present (Elab_Unit)) and then not Is_Compilation_Unit (Elab_Unit) loop Elab_Unit := Scope (Elab_Unit); end loop; end; - elsif Nkind (Original_Node (Call)) = N_Selected_Component then - -- If original node uses selected component notation, the - -- prefix is visible and determines the scope that must be - -- elaborated. After rewriting, the prefix is the first actual - -- in the call. + -- If original node uses selected component notation, the prefix is + -- visible and determines the scope that must be elaborated. After + -- rewriting, the prefix is the first actual in the call. + elsif Nkind (Original_Node (Call)) = N_Selected_Component then Elab_Unit := Scope (Etype (First (Parameter_Associations (Call)))); + -- Not one of special cases above + else -- Using previously computed scope. If the elaboration check is -- done after analysis, the scope is not visible any longer, but @@ -2122,7 +2243,7 @@ package body Sem_Elab is Elab_Unit := Scop; end if; - Set_Elaborate_All_Desirable (Elab_Unit); + Activate_Elaborate_All_Desirable (Call, Elab_Unit); Set_Suppress_Elaboration_Warnings (Elab_Unit, True); end Set_Elaboration_Constraint; @@ -2268,7 +2389,7 @@ package body Sem_Elab is -- Otherwise look and see if we are embedded in a further package - elsif Is_Package (Scop) then + elsif Is_Package_Or_Generic_Package (Scop) then -- If so, get the body of the enclosing package, and look in -- its package body for the package body we are looking for. @@ -2311,16 +2432,15 @@ package body Sem_Elab is -- Case of entity is in other than a package spec, in this case -- the body, if present, must be in the same declarative part. - if not Is_Package (Scop) then + if not Is_Package_Or_Generic_Package (Scop) then declare P : Node_Id; begin - P := Declaration_Node (Ent); - -- Declaration node may get us a spec, so if so, go to -- the parent declaration. + P := Declaration_Node (Ent); while not Is_List_Member (P) loop P := Parent (P); end loop; @@ -2532,18 +2652,26 @@ package body Sem_Elab is ---------------------------- function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean is - S1 : Entity_Id := Scop1; - S2 : Entity_Id := Scop2; + S1 : Entity_Id; + S2 : Entity_Id; begin + -- Find elaboration scope for Scop1 + + S1 := Scop1; while S1 /= Standard_Standard and then (Ekind (S1) = E_Package or else + Ekind (S1) = E_Protected_Type + or else Ekind (S1) = E_Block) loop S1 := Scope (S1); end loop; + -- Find elaboration scope for Scop2 + + S2 := Scop2; while S2 /= Standard_Standard and then (Ekind (S2) = E_Package or else @@ -2606,7 +2734,6 @@ package body Sem_Elab is if Nkind (N) = N_Subprogram_Declaration then declare Ent : constant Entity_Id := Defining_Unit_Name (Specification (N)); - begin Set_Is_Imported (Ent); Set_Convention (Ent, Convention_Stubbed); @@ -2615,7 +2742,6 @@ package body Sem_Elab is elsif Nkind (N) = N_Package_Declaration then declare Spec : constant Node_Id := Specification (N); - begin New_Scope (Defining_Unit_Name (Spec)); Supply_Bodies (Visible_Declarations (Spec)); @@ -2627,7 +2753,6 @@ package body Sem_Elab is procedure Supply_Bodies (L : List_Id) is Elmt : Node_Id; - begin if Present (L) then Elmt := First (L); @@ -2647,7 +2772,6 @@ package body Sem_Elab is begin Scop := E1; - loop if Scop = E2 then return True; @@ -2675,25 +2799,23 @@ package body Sem_Elab is begin Item := First (Context_Items (Cunit (Current_Sem_Unit))); - while Present (Item) loop if Nkind (Item) = N_Pragma and then Get_Pragma_Id (Chars (Item)) = Pragma_Elaborate_All then - if Error_Posted (Item) then - - -- Some previous error on the pragma itself + -- Return if some previous error on the pragma itself + if Error_Posted (Item) then return False; end if; Elab_Id := - Entity ( - Expression (First (Pragma_Argument_Associations (Item)))); + Entity + (Expression (First (Pragma_Argument_Associations (Item)))); - Par := Parent (Unit_Declaration_Node (Elab_Id)); - Item2 := First (Context_Items (Par)); + Par := Parent (Unit_Declaration_Node (Elab_Id)); + Item2 := First (Context_Items (Par)); while Present (Item2) loop if Nkind (Item2) = N_With_Clause and then Entity (Name (Item2)) = E diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 83e094caae3..673d4541782 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, 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- -- @@ -175,6 +175,15 @@ package body Sinfo is return Flag4 (N); end Acts_As_Spec; + function Actual_Designated_Subtype + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Explicit_Dereference + or else NT (N).Nkind = N_Free_Statement); + return Node2 (N); + end Actual_Designated_Subtype; + function Aggregate_Bounds (N : Node_Id) return Node_Id is begin @@ -876,6 +885,14 @@ package body Sinfo is return Flag13 (N); end Do_Tag_Check; + function Elaborate_All_Desirable + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + return Flag9 (N); + end Elaborate_All_Desirable; + function Elaborate_All_Present (N : Node_Id) return Boolean is begin @@ -884,6 +901,14 @@ package body Sinfo is return Flag14 (N); end Elaborate_All_Present; + function Elaborate_Desirable + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + return Flag11 (N); + end Elaborate_Desirable; + function Elaborate_Present (N : Node_Id) return Boolean is begin @@ -2745,6 +2770,15 @@ package body Sinfo is Set_Flag4 (N, Val); end Set_Acts_As_Spec; + procedure Set_Actual_Designated_Subtype + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Explicit_Dereference + or else NT (N).Nkind = N_Free_Statement); + Set_Node2 (N, Val); + end Set_Actual_Designated_Subtype; + procedure Set_Aggregate_Bounds (N : Node_Id; Val : Node_Id) is begin @@ -3446,6 +3480,14 @@ package body Sinfo is Set_Flag13 (N, Val); end Set_Do_Tag_Check; + procedure Set_Elaborate_All_Desirable + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + Set_Flag9 (N, Val); + end Set_Elaborate_All_Desirable; + procedure Set_Elaborate_All_Present (N : Node_Id; Val : Boolean := True) is begin @@ -3454,6 +3496,14 @@ package body Sinfo is Set_Flag14 (N, Val); end Set_Elaborate_All_Present; + procedure Set_Elaborate_Desirable + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + Set_Flag11 (N, Val); + end Set_Elaborate_Desirable; + procedure Set_Elaborate_Present (N : Node_Id; Val : Boolean := True) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 6bc6926bba1..60f8be32224 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, 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- -- @@ -90,11 +90,11 @@ package Sinfo is -- node in the checks. -- Add an appropriate section to the case statement in sprint.adb -- Add an appropriate section to the case statement in sem.adb - -- Add an appropraite section to the case statement in exp_util.adb + -- Add an appropriate section to the case statement in exp_util.adb -- (Insert_Actions procedure) - -- For a subexpression, add an appropriate sections to the case + -- For a subexpression, add an appropriate section to the case -- statement in sem_eval.adb - -- For a subexpression, add an appropriate sections to the case + -- For a subexpression, add an appropriate section to the case -- statement in sem_res.adb -- Finally, four utility programs must be run: @@ -457,27 +457,36 @@ package Sinfo is -- The following flag fields appear in all nodes - -- Analyzed + -- Analyzed (Flag1) -- This flag is used to indicate that a node (and all its children -- have been analyzed. It is used to avoid reanalysis of a node that -- has already been analyzed, both for efficiency and functional -- correctness reasons. - -- Error_Posted + -- Comes_From_Source (Flag2) + -- This flag is on for any nodes built by the scanner or parser from + -- the source program, and off for any nodes built by the analyzer or + -- expander. It indicates that a node comes from the original source. + -- This flag is defined in Atree. + + -- Error_Posted (Flag3) -- This flag is used to avoid multiple error messages being posted -- on or referring to the same node. This flag is set if an error -- message refers to a node or is posted on its source location, -- and has the effect of inhibiting further messages involving -- this same node. - -- Comes_From_Source - -- This flag is on for any nodes built by the scanner or parser from - -- the source program, and off for any nodes built by the analyzer or - -- expander. It indicates that a node comes from the original source. - -- This flag is defined in Atree. + -- Has_Dynamic_Length_Check (Flag10-Sem) + -- This flag is present on all nodes. It is set to indicate that one + -- of the routines in unit Checks has generated a length check action + -- which has been inserted at the flagged node. This is used to avoid + -- the generation of duplicate checks. - -- Has_Dynamic_Length_Check and Has_Dynamic_Range_Check also appear on - -- all nodes. They are fully described in the next section. + -- Has_Dynamic_Range_Check (Flag12-Sem) + -- This flag is present on all nodes. It is set to indicate that one + -- of the routines in unit Checks has generated a range check action + -- which has been inserted at the flagged node. This is used to avoid + -- the generation of duplicate checks. ------------------------------------ -- Description of Semantic Fields -- @@ -535,6 +544,15 @@ package Sinfo is -- compilation unit node at the library level for such a subprogram -- (see further description in spec of Lib package). + -- Actual_Designated_Subtype (Node2-Sem) + -- Present in N_Free_Statement and N_Explicit_Dereference nodes. If + -- GIGI needs to known the dynamic constrained subtype of the designated + -- object, this attribute is set to that type. This is done for + -- N_Free_Statements for access-to-classwide types and access to + -- unconstrained packed array types, and for N_Explicit_Dereference + -- when the designated type is an unconstrained packed array and the + -- dereference is the prefix of a 'Size attribute reference. + -- Aggregate_Bounds (Node3-Sem) -- Present in array N_Aggregate nodes. If the aggregate contains -- component associations this field points to an N_Range node whose @@ -831,13 +849,23 @@ package Sinfo is -- yet decided how this flag is used (TBD ???). -- Elaborate_Present (Flag4-Sem) - -- This flag is set in the N_With_Clause node to indicate that a - -- pragma Elaborate pragma appears for the with'ed units. + -- This flag is set in the N_With_Clause node to indicate that pragma + -- Elaborate pragma appears for the with'ed units. + + -- Elaborate_All_Desirable (Flag9-Sem) + -- This flag is set in the N_With_Clause mode to indicate that the static + -- elaboration processing has determined that an Elaborate_All pragma is + -- desirable for correct elaboration for this unit. -- Elaborate_All_Present (Flag14-Sem) -- This flag is set in the N_With_Clause node to indicate that a -- pragma Elaborate_All pragma appears for the with'ed units. + -- Elaborate_Desirable (Flag11-Sem) + -- This flag is set in the N_With_Clause mode to indicate that the static + -- elaboration processing has determined that an Elaborate pragma is + -- desirable for correct elaboration for this unit. + -- Elaboration_Boolean (Node2-Sem) -- This field is present in function and procedure specification -- nodes. If set, it points to the entity for a Boolean flag that @@ -1008,18 +1036,6 @@ package Sinfo is -- handler is deleted during optimization. For further details on why -- this is required, see Exp_Ch11.Remove_Handler_Entries. - -- Has_Dynamic_Length_Check (Flag10-Sem) - -- This flag is present on all nodes. It is set to indicate that one - -- of the routines in unit Checks has generated a length check action - -- which has been inserted at the flagged node. This is used to avoid - -- the generation of duplicate checks. - - -- Has_Dynamic_Range_Check (Flag12-Sem) - -- This flag is present on all nodes. It is set to indicate that one - -- of the routines in unit Checks has generated a range check action - -- which has been inserted at the flagged node. This is used to avoid - -- the generation of duplicate checks. - -- Has_No_Elaboration_Code (Flag17-Sem) -- A flag that appears in the N_Compilation_Unit node to indicate -- whether or not elaboration code is present for this unit. It is @@ -2847,6 +2863,7 @@ package Sinfo is -- N_Explicit_Dereference -- Sloc points to ALL -- Prefix (Node3) + -- Actual_Designated_Subtype (Node2-Sem) -- plus fields for expression ------------------------------- @@ -5217,6 +5234,8 @@ package Sinfo is -- Context_Installed (Flag13-Sem) -- Elaborate_Present (Flag4-Sem) -- Elaborate_All_Present (Flag14-Sem) + -- Elaborate_All_Desirable (Flag9-Sem) + -- Elaborate_Desirable (Flag11-Sem) -- Private_Present (Flag15) set if with_clause has private keyword -- Implicit_With (Flag16-Sem) -- Limited_Present (Flag17) set if LIMITED is present @@ -6233,6 +6252,7 @@ package Sinfo is -- Expression (Node3) argument to unchecked deallocation call -- Storage_Pool (Node1-Sem) -- Procedure_To_Call (Node4-Sem) + -- Actual_Designated_Subtype (Node2-Sem) -- Note: in the case where a debug source file is generated, the Sloc -- for this node points to the FREE keyword in the Sprint file output. @@ -6757,11 +6777,15 @@ package Sinfo is N_Task_Body_Stub, -- N_Generic_Instantiation, N_Later_Decl_Item + -- N_Subprogram_Instantiation N_Function_Instantiation, - N_Package_Instantiation, N_Procedure_Instantiation, + -- N_Generic_Instantiation, N_Later_Decl_Item + + N_Package_Instantiation, + -- N_Unit_Body, N_Later_Decl_Item, N_Proper_Body N_Package_Body, @@ -6797,7 +6821,7 @@ package Sinfo is N_Package_Renaming_Declaration, N_Subprogram_Renaming_Declaration, - -- N_Generic_Renaming_Declarations, N_Renaming_Declaration + -- N_Generic_Renaming_Declaration, N_Renaming_Declaration N_Generic_Function_Renaming_Declaration, N_Generic_Package_Renaming_Declaration, @@ -6813,8 +6837,14 @@ package Sinfo is N_Case_Statement, N_Code_Statement, N_Conditional_Entry_Call, + + -- N_Statement_Other_Than_Procedure_Call. N_Delay_Statement + N_Delay_Relative_Statement, N_Delay_Until_Statement, + + -- N_Statement_Other_Than_Procedure_Call + N_Entry_Call_Statement, N_Free_Statement, N_Goto_Statement, @@ -6940,6 +6970,10 @@ package Sinfo is -- Note: this includes all constructs normally thought of as declarations -- except those which are separately grouped as later declarations. + subtype N_Delay_Statement is Node_Kind range + N_Delay_Relative_Statement .. + N_Delay_Until_Statement; + subtype N_Direct_Name is Node_Kind range N_Identifier .. N_Character_Literal; @@ -6958,7 +6992,7 @@ package Sinfo is subtype N_Generic_Instantiation is Node_Kind range N_Function_Instantiation .. - N_Procedure_Instantiation; + N_Package_Instantiation; subtype N_Generic_Renaming_Declaration is Node_Kind range N_Generic_Function_Renaming_Declaration .. @@ -7036,6 +7070,10 @@ package Sinfo is -- (since overloading is possible, so it needs to go through the normal -- overloading resolution for expressions). + subtype N_Subprogram_Instantiation is Node_Kind range + N_Function_Instantiation .. + N_Procedure_Instantiation; + subtype N_Has_Condition is Node_Kind range N_Exit_Statement .. N_Terminate_Alternative; @@ -7106,6 +7144,9 @@ package Sinfo is function Acts_As_Spec (N : Node_Id) return Boolean; -- Flag4 + function Actual_Designated_Subtype + (N : Node_Id) return Node_Id; -- Node2 + function Aggregate_Bounds (N : Node_Id) return Node_Id; -- Node3 @@ -7325,9 +7366,15 @@ package Sinfo is function Do_Tag_Check (N : Node_Id) return Boolean; -- Flag13 + function Elaborate_All_Desirable + (N : Node_Id) return Boolean; -- Flag9 + function Elaborate_All_Present (N : Node_Id) return Boolean; -- Flag14 + function Elaborate_Desirable + (N : Node_Id) return Boolean; -- Flag11 + function Elaborate_Present (N : Node_Id) return Boolean; -- Flag4 @@ -7919,6 +7966,9 @@ package Sinfo is procedure Set_Acts_As_Spec (N : Node_Id; Val : Boolean := True); -- Flag4 + procedure Set_Actual_Designated_Subtype + (N : Node_Id; Val : Node_Id); -- Node2 + procedure Set_Aggregate_Bounds (N : Node_Id; Val : Node_Id); -- Node3 @@ -8138,9 +8188,15 @@ package Sinfo is procedure Set_Do_Tag_Check (N : Node_Id; Val : Boolean := True); -- Flag13 + procedure Set_Elaborate_All_Desirable + (N : Node_Id; Val : Boolean := True); -- Flag9 + procedure Set_Elaborate_All_Present (N : Node_Id; Val : Boolean := True); -- Flag14 + procedure Set_Elaborate_Desirable + (N : Node_Id; Val : Boolean := True); -- Flag11 + procedure Set_Elaborate_Present (N : Node_Id; Val : Boolean := True); -- Flag4 @@ -8723,6 +8779,7 @@ package Sinfo is pragma Inline (Actions); pragma Inline (Activation_Chain_Entity); pragma Inline (Acts_As_Spec); + pragma Inline (Actual_Designated_Subtype); pragma Inline (Aggregate_Bounds); pragma Inline (Aliased_Present); pragma Inline (All_Others); @@ -8797,7 +8854,9 @@ package Sinfo is pragma Inline (Do_Storage_Check); pragma Inline (Do_Tag_Check); pragma Inline (Elaborate_Present); + pragma Inline (Elaborate_All_Desirable); pragma Inline (Elaborate_All_Present); + pragma Inline (Elaborate_Desirable); pragma Inline (Elaboration_Boolean); pragma Inline (Else_Actions); pragma Inline (Else_Statements); @@ -8991,6 +9050,7 @@ package Sinfo is pragma Inline (Set_Actions); pragma Inline (Set_Activation_Chain_Entity); pragma Inline (Set_Acts_As_Spec); + pragma Inline (Set_Actual_Designated_Subtype); pragma Inline (Set_Aggregate_Bounds); pragma Inline (Set_Aliased_Present); pragma Inline (Set_All_Others); @@ -9065,7 +9125,9 @@ package Sinfo is pragma Inline (Set_Do_Storage_Check); pragma Inline (Set_Do_Tag_Check); pragma Inline (Set_Elaborate_Present); + pragma Inline (Set_Elaborate_All_Desirable); pragma Inline (Set_Elaborate_All_Present); + pragma Inline (Set_Elaborate_Desirable); pragma Inline (Set_Elaboration_Boolean); pragma Inline (Set_Else_Actions); pragma Inline (Set_Else_Statements); |