Skip to content

R
riscv-gcc-1
Commit bde33286 by Robert Dewar Committed by Arnaud Charlet
Options

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