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 169 additions and 44 deletions
gcc/ada/ali.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -1556,6 +1556,7 @@ package body ALI is
Withs.Table (Withs.Last).Uname := Get_Name;
Withs.Table (Withs.Last).Elaborate := False;
Withs.Table (Withs.Last).Elaborate_All := False;
Withs.Table (Withs.Last).Elab_Desirable := False;
Withs.Table (Withs.Last).Elab_All_Desirable := False;
Withs.Table (Withs.Last).SAL_Interface := False;
......@@ -1571,12 +1572,24 @@ package body ALI is
Withs.Table (Withs.Last).Sfile := Get_Name (Lower => True);
Withs.Table (Withs.Last).Afile := Get_Name;
-- Scan out possible E, EA, and NE parameters
-- Scan out possible E, EA, ED, and AD parameters
while not At_Eol loop
Skip_Space;
if Nextc = 'E' then
if Nextc = 'A' then
P := P + 1;
Checkc ('D');
Check_At_End_Of_Field;
-- Store AD indication unless ignore required
if not Ignore_ED then
Withs.Table (Withs.Last).Elab_All_Desirable :=
True;
end if;
elsif Nextc = 'E' then
P := P + 1;
if At_End_Of_Field then
......@@ -1594,7 +1607,7 @@ package body ALI is
-- Store ED indication unless ignore required
if not Ignore_ED then
Withs.Table (Withs.Last).Elab_All_Desirable :=
Withs.Table (Withs.Last).Elab_Desirable :=
True;
end if;
end if;
......
gcc/ada/ali.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -473,6 +473,9 @@ package ALI is
-- Indicates presence of EA parameter
Elab_All_Desirable : Boolean;
-- Indicates presence of AD parameter
Elab_Desirable : Boolean;
-- Indicates presence of ED parameter
SAL_Interface : Boolean := False;
......@@ -872,7 +875,7 @@ package ALI is
-- switch description settings.
--
-- Ignore_ED is normally False. If set to True, it indicates that
-- all ED (elaboration desirable) indications in the ALI file are
-- all AD/ED (elaboration desirable) indications in the ALI file are
-- to be ignored. This parameter is obsolete now that the -f switch
-- is removed from gnatbind, and should be removed ???
--
......
gcc/ada/binde.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -72,11 +72,16 @@ package body Binde is
-- elaborated before unit X is elaborated. The Elab_All_Link list
-- traces the dependencies in the latter case.
Elab_Desirable,
Elab_All_Desirable,
-- This is just like Elab_All, except that the elaborate all was not
-- explicitly present in the source, but rather was created by the
-- front end, which decided that it was "desirable".
Elab_Desirable,
-- This is just like Elab, except that the elaborate was not
-- explicitly present in the source, but rather was created by the
-- front end, which decided that it was "desirable".
Spec_First);
-- After is a body, and Before is the corresponding spec
......@@ -249,7 +254,7 @@ package body Binde is
Link : Elab_All_Id);
-- Used to compute the transitive closure of elaboration links for an
-- Elaborate_All pragma (Reason = Elab_All) or for an indication of
-- Elaborate_All_Desirable (Reason = Elab_Desirable). Unit After has
-- Elaborate_All_Desirable (Reason = Elab_All_Desirable). Unit After has
-- a pragma Elaborate_All or the front end has determined that a reference
-- probably requires Elaborate_All is required, and unit Before must be
-- previously elaborated. First a link is built making sure that unit
......@@ -268,8 +273,7 @@ package body Binde is
function Make_Elab_Entry
(Unam : Unit_Name_Type;
Link : Elab_All_Id)
return Elab_All_Id;
Link : Elab_All_Id) return Elab_All_Id;
-- Make an Elab_All_Entries table entry with the given Unam and Link
function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id;
......@@ -800,9 +804,9 @@ package body Binde is
SL : Successor_Link renames Succ.Table (S);
begin
-- Nothing to do if internal unit involved and no -de flag
-- Nothing to do if internal unit involved and no -da flag
if not Debug_Flag_E
if not Debug_Flag_A
and then
(Is_Internal_File_Name (Units.Table (SL.Before).Sfile)
or else
......@@ -841,7 +845,7 @@ package body Binde is
(" reason: pragma Elaborate_All in unit &",
Info => True);
when Elab_Desirable =>
when Elab_All_Desirable =>
Error_Msg_Output
(" reason: implicit Elaborate_All in unit &",
Info => True);
......@@ -850,6 +854,15 @@ package body Binde is
(" recompile & with -gnatwl for full details",
Info => True);
when Elab_Desirable =>
Error_Msg_Output
(" reason: implicit Elaborate in unit &",
Info => True);
Error_Msg_Output
(" recompile & with -gnatwl for full details",
Info => True);
when Spec_First =>
Error_Msg_Output
(" reason: spec always elaborated before body",
......@@ -1092,7 +1105,7 @@ package body Binde is
-- Now establish all the links we need
Elab_All_Links
(Withed_Unit, U, Elab_Desirable,
(Withed_Unit, U, Elab_All_Desirable,
Make_Elab_Entry
(Withs.Table (W).Uname, No_Elab_All_Link));
......@@ -1116,6 +1129,18 @@ package body Binde is
(Corresponding_Body (Withed_Unit), U, Elab);
end if;
-- Elaborate_Desirable case, for this we establish
-- the same links as above, but with a different reason.
elsif Withs.Table (W).Elab_Desirable then
Build_Link (Withed_Unit, U, Withed);
if Units.Table (Withed_Unit).Utype = Is_Spec then
Build_Link
(Corresponding_Body (Withed_Unit),
U, Elab_Desirable);
end if;
-- Case of normal WITH with no elaboration pragmas, just
-- build the single link to the directly referenced unit
......@@ -1137,8 +1162,7 @@ package body Binde is
function Make_Elab_Entry
(Unam : Unit_Name_Type;
Link : Elab_All_Id)
return Elab_All_Id
Link : Elab_All_Id) return Elab_All_Id
is
begin
Elab_All_Entries.Increment_Last;
......@@ -1153,7 +1177,6 @@ package body Binde is
function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is
Info : constant Int := Get_Name_Table_Info (Uname);
begin
pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id);
return Unit_Id (Info);
......@@ -1172,12 +1195,20 @@ package body Binde is
-- Determines if U is a waiting body, defined as a body which has
-- not been elaborated, but whose spec has been elaborated.
---------------
-- Body_Unit --
---------------
function Body_Unit (U : Unit_Id) return Boolean is
begin
return Units.Table (U).Utype = Is_Body
or else Units.Table (U).Utype = Is_Body_Only;
end Body_Unit;
------------------
-- Waiting_Body --
------------------
function Waiting_Body (U : Unit_Id) return Boolean is
begin
return Units.Table (U).Utype = Is_Body and then
......@@ -1186,10 +1217,10 @@ package body Binde is
-- Start of processing for Worse_Choice
-- Note: the checks here are applied in sequence, and the ordering is
-- significant (i.e. the more important criteria are applied first).
begin
-- Note: the checks here are applied in sequence, and the ordering is
-- significant (i.e. the more important criteria are applied first).
-- If either unit is internal, then use Better_Choice, since the
-- language requires that predefined units not mess up in the choice
-- of elaboration order, and for internal units, any problems are
......@@ -1277,7 +1308,7 @@ package body Binde is
First_Name : Boolean := True;
begin
if ST.Reason in Elab_All .. Elab_Desirable then
if ST.Reason in Elab_All .. Elab_All_Desirable then
L := ST.Elab_All_Link;
while L /= No_Elab_All_Link loop
Nam := Elab_All_Entries.Table (L).Needed_By;
......
gcc/ada/debug.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -98,7 +98,7 @@ package body Debug is
-- d.c
-- d.d
-- d.e
-- d.f
-- d.f Inhibit folding of static expressions
-- d.g
-- d.h
-- d.i
......@@ -132,7 +132,7 @@ package body Debug is
-- Debug flags for binder (GNATBIND)
-- da
-- da All links (including internal units) listed if there is a cycle
-- db
-- dc List units as they are chosen
-- dd
......@@ -410,7 +410,7 @@ package body Debug is
-- indications. This debug flag disconnects the tracking of constant
-- values (see Exp_Ch2.Expand_Current_Value).
-- dN Do not generate file name information in exception messages.
-- dN Do not generate file name information in exception messages
-- dO Output immediate error messages. This causes error messages to
-- be output as soon as they are generated (disconnecting several
......@@ -461,6 +461,10 @@ package body Debug is
-- had Configurable_Run_Time_Mode set to True. This is useful in
-- testing high integrity mode.
-- d.f Suppress folding of static expressions. This of course results
-- in seriously non-conforming behavior, but is useful sometimes
-- when tracking down handling of complex expressions.
-- d.x No exception handlers in generated code. This causes exception
-- handlers to be eliminated from the generated code. They are still
-- fully compiled and analyzed, they just get eliminated from the
......@@ -511,6 +515,12 @@ package body Debug is
-- Documentation for Binder Debug Flags --
------------------------------------------
-- da Normally if there is an elaboration circularity, then in describing
-- the cycle, links involving internal units are omitted, since they
-- are irrelevant and confusing. This debug flag causes all links to
-- be listed, and is useful when diagnosing circularities introduced
-- by incorrect changes to the run-time library itself.
-- dc List units as they are chosen. As units are selected for addition to
-- the elaboration order, a line of output is generated showing which
-- unit has been selected.
......
gcc/ada/lib-writ.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -182,6 +182,9 @@ package body Lib.Writ is
-- Array of flags to show which units have pragma Elaborate All set
Elab_Des_Flags : array (Units.First .. Last_Unit) of Boolean;
-- Array of flags to show which units have Elaborate_Desirable set
Elab_All_Des_Flags : array (Units.First .. Last_Unit) of Boolean;
-- Array of flags to show which units have Elaborate_All_Desirable set
Sdep_Table : Unit_Ref_Table (1 .. Pos (Last_Unit - Units.First + 2));
......@@ -229,11 +232,13 @@ package body Lib.Writ is
Item := First (Context_Items (Cunit));
while Present (Item) loop
-- Process with clause
-- Ada 2005 (AI-50217): limited with_clauses do not create
-- dependencies
if Nkind (Item) = N_With_Clause
and then not (Limited_Present (Item))
and then not (Limited_Present (Item))
then
Unum := Get_Cunit_Unit_Number (Library_Unit (Item));
With_Flags (Unum) := True;
......@@ -246,7 +251,11 @@ package body Lib.Writ is
Elab_All_Flags (Unum) := True;
end if;
if Elaborate_All_Desirable (Cunit_Entity (Unum)) then
if Elaborate_All_Desirable (Item) then
Elab_All_Des_Flags (Unum) := True;
end if;
if Elaborate_Desirable (Item) then
Elab_Des_Flags (Unum) := True;
end if;
end if;
......@@ -495,10 +504,11 @@ package body Lib.Writ is
-- Generate with lines, first those that are directly with'ed
for J in With_Flags'Range loop
With_Flags (J) := False;
Elab_Flags (J) := False;
Elab_All_Flags (J) := False;
Elab_Des_Flags (J) := False;
With_Flags (J) := False;
Elab_Flags (J) := False;
Elab_All_Flags (J) := False;
Elab_Des_Flags (J) := False;
Elab_All_Des_Flags (J) := False;
end loop;
Collect_Withs (Unode);
......@@ -725,6 +735,10 @@ package body Lib.Writ is
if Elab_Des_Flags (Unum) then
Write_Info_Str (" ED");
end if;
if Elab_All_Des_Flags (Unum) then
Write_Info_Str (" AD");
end if;
end if;
Write_Info_EOL;
......@@ -818,12 +832,10 @@ package body Lib.Writ is
begin
if Nkind (U) = N_Subprogram_Body
or else (Nkind (U) = N_Package_Body
and then
(Nkind (Original_Node (U)) = N_Function_Instantiation
or else
Nkind (Original_Node (U)) =
N_Procedure_Instantiation))
or else
(Nkind (U) = N_Package_Body
and then
Nkind (Original_Node (U)) in N_Subprogram_Instantiation)
then
-- If the unit is a subprogram instance, the entity for the
-- subprogram is the alias of the visible entity, which is the
......
gcc/ada/lib-writ.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -462,7 +462,7 @@ package Lib.Writ is
-- Following each U line, is a series of lines of the form
-- W unit-name [source-name lib-name] [E] [EA] [ED]
-- W unit-name [source-name lib-name] [E] [EA] [ED] [AD]
--
-- One of these lines is present for each unit that is mentioned in
-- an explicit with clause by the current unit. The first parameter
......@@ -479,11 +479,17 @@ package Lib.Writ is
--
-- EA pragma Elaborate_All applies to this unit
--
-- ED Elaborate_All_Desirable set for this unit, which means
-- ED Elaborate_Desirable set for this unit, which means
-- that there is no Elaborate, but the analysis suggests
-- that Program_Error may be raised if the Elaborate
-- conditions cannot be satisfied. The binder will attempt
-- to treat ED as E if it can.
--
-- AD Elaborate_All_Desirable set for this unit, which means
-- that there is no Elaborate_All, but the analysis suggests
-- that Program_Error may be raised if the Elaborate_All
-- conditions cannot be satisfied. The binder will attempt
-- to treat ED as EA if it can.
-- to treat AD as EA if it can.
--
-- The parameter source-name and lib-name are omitted for the case
-- of a generic unit compiled with earlier versions of GNAT which
......
gcc/ada/sinfo.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -175,6 +175,15 @@ package body Sinfo is
return Flag4 (N);
end Acts_As_Spec;
function Actual_Designated_Subtype
(N : Node_Id) return Node_Id is
begin
pragma Assert (False
or else NT (N).Nkind = N_Explicit_Dereference
or else NT (N).Nkind = N_Free_Statement);
return Node2 (N);
end Actual_Designated_Subtype;
function Aggregate_Bounds
(N : Node_Id) return Node_Id is
begin
......@@ -876,6 +885,14 @@ package body Sinfo is
return Flag13 (N);
end Do_Tag_Check;
function Elaborate_All_Desirable
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_With_Clause);
return Flag9 (N);
end Elaborate_All_Desirable;
function Elaborate_All_Present
(N : Node_Id) return Boolean is
begin
......@@ -884,6 +901,14 @@ package body Sinfo is
return Flag14 (N);
end Elaborate_All_Present;
function Elaborate_Desirable
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_With_Clause);
return Flag11 (N);
end Elaborate_Desirable;
function Elaborate_Present
(N : Node_Id) return Boolean is
begin
......@@ -2745,6 +2770,15 @@ package body Sinfo is
Set_Flag4 (N, Val);
end Set_Acts_As_Spec;
procedure Set_Actual_Designated_Subtype
(N : Node_Id; Val : Node_Id) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Explicit_Dereference
or else NT (N).Nkind = N_Free_Statement);
Set_Node2 (N, Val);
end Set_Actual_Designated_Subtype;
procedure Set_Aggregate_Bounds
(N : Node_Id; Val : Node_Id) is
begin
......@@ -3446,6 +3480,14 @@ package body Sinfo is
Set_Flag13 (N, Val);
end Set_Do_Tag_Check;
procedure Set_Elaborate_All_Desirable
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_With_Clause);
Set_Flag9 (N, Val);
end Set_Elaborate_All_Desirable;
procedure Set_Elaborate_All_Present
(N : Node_Id; Val : Boolean := True) is
begin
......@@ -3454,6 +3496,14 @@ package body Sinfo is
Set_Flag14 (N, Val);
end Set_Elaborate_All_Present;
procedure Set_Elaborate_Desirable
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_With_Clause);
Set_Flag11 (N, Val);
end Set_Elaborate_Desirable;
procedure Set_Elaborate_Present
(N : Node_Id; Val : Boolean := True) is
begin
......
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