OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

sem_elab.adb: Change name Is_Package to Is_Package_Or_Generic_Package 

2005-11-14  Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* sem_elab.adb: Change name Is_Package to Is_Package_Or_Generic_Package
	(Check_Elab_Call): A call within a protected body is never an
	elaboration call, and does not require checking.
	(Same_Elaboration_Scope): Take into account protected types for both
	entities.
	(Activate_Elaborate_All_Desirable): New procedure

	* ali.ads, ali.adb: Implement new AD/ED for Elaborate_All/Elaborate
	desirable

	* binde.adb: Implement new AD/ED for Elaborate_All/Elaborate desirable
	(Elab_Error_Msg): Use -da to include internal unit links, not -de.

	* lib-writ.ads, lib-writ.adb: 
	Implement new AD/ED for Elaborate_All/Elaborate desirable
	Use new Elaborate_All_Desirable flag in N_With_Clause node

	* sinfo.ads, sinfo.adb (Actual_Designated_Subtype): New attribute for
	N_Free_Statement nodes.
	Define new class N_Subprogram_Instantiation
	Add Elaborate_Desirable flag to N_With_Clause node
	Add N_Delay_Statement (covering two kinds of delay)

	* debug.adb: Introduce d.f flag for compiler
	Add -da switch for binder

From-SVN: r106968
This commit is contained in:
Robert Dewar 2005-11-15 14:56:27 +01:00 committed by Arnaud Charlet
parent 104e4daaa5
commit bde33286bd
9 changed files with 433 additions and 124 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
gcc/ada/ali.adb
View File

@ -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;

7
gcc/ada/ali.ads
View File

@ -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 ???
--

63
gcc/ada/binde.adb
View File

@ -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;

18
gcc/ada/debug.adb
View File

@ -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.

38
gcc/ada/lib-writ.adb
View File

@ -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

14
gcc/ada/lib-writ.ads
View File

@ -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

222
gcc/ada/sem_elab.adb
View File

@ -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;
-- 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
-- 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.
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
-- Return if some previous error on the pragma itself
if Error_Posted (Item) then
-- Some previous error on the pragma itself
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));
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

52
gcc/ada/sinfo.adb
View File

@ -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

122
gcc/ada/sinfo.ads
View File

@ -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);