-- --
-- 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- --
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;
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
-- 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;
-- --
-- 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- --
-- 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;
-- 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 ???
--
-- --
-- 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- --
-- 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
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
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;
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
(" 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);
(" 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",
-- 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));
(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
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;
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);
-- 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
-- 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
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;
-- --
-- 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- --
-- d.c
-- d.d
-- d.e
- -- d.f
+ -- d.f Inhibit folding of static expressions
-- d.g
-- d.h
-- d.i
-- 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
-- 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
-- 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
-- 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.
-- --
-- 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- --
-- 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));
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;
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;
-- 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);
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;
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
-- --
-- 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- --
-- 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
--
-- 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
-- --
-- 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- --
Outer_Scope : Entity_Id;
-- Save scope of outer level call
-
end record;
package Delay_Check is new Table.Table (
-- 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;
-- 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 --
------------------
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;
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);
("\?Program_Error will be raised at run time", N);
Insert_Elab_Check (N);
Set_ABE_Is_Certain (N);
-
end Check_Bad_Instantiation;
---------------------
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;
else
Check_Internal_Call_Continue (N, E, Outer_Scope, Orig_Ent);
end if;
-
end Check_Internal_Call;
----------------------------------
-- 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);
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);
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;
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
----------------
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;
-- 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));
" 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;
-- 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);
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;
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
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
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;
-- 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.
-- 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;
----------------------------
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
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);
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));
procedure Supply_Bodies (L : List_Id) is
Elmt : Node_Id;
-
begin
if Present (L) then
Elmt := First (L);
begin
Scop := E1;
-
loop
if Scop = E2 then
return True;
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
-- --
-- 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- --
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
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
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
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
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
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
-- --
-- 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- --
-- 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:
-- 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 --
-- 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
-- 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
-- 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
-- N_Explicit_Dereference
-- Sloc points to ALL
-- Prefix (Node3)
+ -- Actual_Designated_Subtype (Node2-Sem)
-- plus fields for expression
-------------------------------
-- 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
-- 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.
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,
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,
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,
-- 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;
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 ..
-- (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;
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
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
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
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
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);
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);
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);
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);
projects / platform / upstream / gcc.git / commitdiff