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

errout.ads: Update comments for new handling of info: messages 

2008-04-08  Robert Dewar  <dewar@adacore.com>

	* errout.ads: Update comments for new handling of info: messages

	* erroutc.adb (Matches): New procedure
	(Warning_Specifically_Suppressed): Modified to handle multiple * chars
	(Is_Style_Or_Info_Msg): New name for Is_Style_Msg, now set for
	 info messages as well as style messages.

	* erroutc.ads: Remove unneeded fields from Specific_Warning_Entry

	* sem_elab.adb (Supply_Bodies): Create actual bodies for stubbed
	subprograms.
	(Check_A_Call): Special "info: " warnings now have ? in the text
	(Elab_Warning): Use info message in static case

From-SVN: r134024
This commit is contained in:
Robert Dewar 2008-04-08 08:49:13 +02:00 committed by Arnaud Charlet
parent 68c3f02a68
commit 2dcf2584db
4 changed files with 356 additions and 365 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
gcc/ada/errout.ads
View File

@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2008, 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- --
@ -275,14 +275,21 @@ package Errout is
-- Insertion character ? (Question: warning message) -- Insertion character ? (Question: warning message)
-- The character ? appearing anywhere in a message makes the message -- The character ? appearing anywhere in a message makes the message
-- warning instead of a normal error message, and the text of the -- warning instead of a normal error message, and the text of the
-- message will be preceded by "Warning:" instead of "Error:" in the -- message will be preceded by "warning:" in the normal case. The
-- normal case. The handling of warnings if further controlled by the -- handling of warnings if further controlled by the Warning_Mode
-- Warning_Mode option (-w switch), see package Opt for further -- option (-w switch), see package Opt for further details, and also by
-- details, and also by the current setting from pragma Warnings. This -- the current setting from pragma Warnings. This pragma applies only
-- pragma applies only to warnings issued from the semantic phase (not -- to warnings issued from the semantic phase (not the parser), but
-- the parser), but currently all relevant warnings are posted by the -- currently all relevant warnings are posted by the semantic phase
-- semantic phase anyway. Messages starting with (style) are also -- anyway. Messages starting with (style) are also treated as warning
-- treated as warning messages. -- messages.
--
-- Note: when a warning message is output, the text of the message is
-- preceded by "warning: " in the normal case. An exception to this
-- rule occurs when the text of the message starts with "info: " in
-- which case this string is not prepended. This allows callers to
-- label certain warnings as informational messages, rather than as
-- warning messages requiring some action.
-- --
-- Note: the presence of ? is ignored in continuation messages (i.e. -- Note: the presence of ? is ignored in continuation messages (i.e.
-- messages starting with the \ insertion character). The warning -- messages starting with the \ insertion character). The warning

301
gcc/ada/erroutc.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2008, 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,6 +117,7 @@ package body Erroutc is
if Errors.Table (D).Warn or Errors.Table (D).Style then if Errors.Table (D).Warn or Errors.Table (D).Style then
Warnings_Detected := Warnings_Detected - 1; Warnings_Detected := Warnings_Detected - 1;
else else
Total_Errors_Detected := Total_Errors_Detected - 1; Total_Errors_Detected := Total_Errors_Detected - 1;
@ -441,6 +442,12 @@ package body Erroutc is
Length : Nat; Length : Nat;
-- Maximum total length of lines -- Maximum total length of lines
Txt : constant String_Ptr := Errors.Table (E).Text;
Len : constant Natural := Txt'Length;
Ptr : Natural;
Split : Natural;
Start : Natural;
begin begin
if Error_Msg_Line_Length = 0 then if Error_Msg_Line_Length = 0 then
Length := Nat'Last; Length := Nat'Last;
@ -450,13 +457,21 @@ package body Erroutc is
Max := Integer (Length - Column + 1); Max := Integer (Length - Column + 1);
-- For warning message, add "warning: " unless msg starts with "info: "
if Errors.Table (E).Warn then if Errors.Table (E).Warn then
Write_Str ("warning: "); if Len < 6 or else Txt (Txt'First .. Txt'First + 5) /= "info: " then
Max := Max - 9; Write_Str ("warning: ");
Max := Max - 9;
end if;
-- No prefix needed for style message, since "(style)" is there already
elsif Errors.Table (E).Style then elsif Errors.Table (E).Style then
null; null;
-- All other cases, add "error: "
elsif Opt.Unique_Error_Tag then elsif Opt.Unique_Error_Tag then
Write_Str ("error: "); Write_Str ("error: ");
Max := Max - 7; Max := Max - 7;
@ -464,74 +479,65 @@ package body Erroutc is
-- Here we have to split the message up into multiple lines -- Here we have to split the message up into multiple lines
declare Ptr := 1;
Txt : constant String_Ptr := Errors.Table (E).Text; loop
Len : constant Natural := Txt'Length; -- Make sure we do not have ludicrously small line
Ptr : Natural;
Split : Natural;
Start : Natural;
begin Max := Integer'Max (Max, 20);
Ptr := 1;
loop
-- Make sure we do not have ludicrously small line
Max := Integer'Max (Max, 20); -- If remaining text fits, output it respecting LF and we are done
-- If remaining text fits, output it respecting LF and we are done if Len - Ptr < Max then
for J in Ptr .. Len loop
if Txt (J) = ASCII.LF then
Write_Eol;
Write_Spaces (Offs);
else
Write_Char (Txt (J));
end if;
end loop;
if Len - Ptr < Max then return;
for J in Ptr .. Len loop
if Txt (J) = ASCII.LF then
Write_Eol;
Write_Spaces (Offs);
else
Write_Char (Txt (J));
end if;
end loop;
return;
-- Line does not fit -- Line does not fit
else else
Start := Ptr; Start := Ptr;
-- First scan forward looing for a hard end of line -- First scan forward looing for a hard end of line
for Scan in Ptr .. Ptr + Max - 1 loop for Scan in Ptr .. Ptr + Max - 1 loop
if Txt (Scan) = ASCII.LF then if Txt (Scan) = ASCII.LF then
Split := Scan - 1; Split := Scan - 1;
Ptr := Scan + 1; Ptr := Scan + 1;
goto Continue; goto Continue;
end if; end if;
end loop; end loop;
-- Otherwise scan backwards looking for a space -- Otherwise scan backwards looking for a space
for Scan in reverse Ptr .. Ptr + Max - 1 loop for Scan in reverse Ptr .. Ptr + Max - 1 loop
if Txt (Scan) = ' ' then if Txt (Scan) = ' ' then
Split := Scan - 1; Split := Scan - 1;
Ptr := Scan + 1; Ptr := Scan + 1;
goto Continue; goto Continue;
end if; end if;
end loop; end loop;
-- If we fall through, no space, so split line arbitrarily -- If we fall through, no space, so split line arbitrarily
Split := Ptr + Max - 1; Split := Ptr + Max - 1;
Ptr := Split + 1; Ptr := Split + 1;
end if; end if;
<<Continue>> <<Continue>>
if Start <= Split then if Start <= Split then
Write_Line (Txt (Start .. Split)); Write_Line (Txt (Start .. Split));
Write_Spaces (Offs); Write_Spaces (Offs);
end if; end if;
Max := Integer (Length - Column + 1); Max := Integer (Length - Column + 1);
end loop; end loop;
end;
end Output_Msg_Text; end Output_Msg_Text;
-------------------- --------------------
@ -557,6 +563,7 @@ package body Erroutc is
then then
if Errors.Table (E).Warn or Errors.Table (E).Style then if Errors.Table (E).Warn or Errors.Table (E).Style then
Warnings_Detected := Warnings_Detected - 1; Warnings_Detected := Warnings_Detected - 1;
else else
Total_Errors_Detected := Total_Errors_Detected - 1; Total_Errors_Detected := Total_Errors_Detected - 1;
@ -1052,40 +1059,13 @@ package body Erroutc is
Msg : String; Msg : String;
Config : Boolean) Config : Boolean)
is is
pragma Assert (Msg'First = 1);
Pattern : String := Msg;
Patlen : Natural := Msg'Length;
Star_Start : Boolean;
Star_End : Boolean;
begin begin
if Pattern (1) = '*' then
Star_Start := True;
Pattern (1 .. Patlen - 1) := Pattern (2 .. Patlen);
Patlen := Patlen - 1;
else
Star_Start := False;
end if;
if Pattern (Patlen) = '*' then
Star_End := True;
Patlen := Patlen - 1;
else
Star_End := False;
end if;
Specific_Warnings.Append Specific_Warnings.Append
((Start => Loc, ((Start => Loc,
Msg => new String'(Msg), Msg => new String'(Msg),
Pattern => new String'(Pattern (1 .. Patlen)),
Patlen => Patlen,
Stop => Source_Last (Current_Source_File), Stop => Source_Last (Current_Source_File),
Open => True, Open => True,
Used => False, Used => False,
Star_Start => Star_Start,
Star_End => Star_End,
Config => Config)); Config => Config));
end Set_Specific_Warning_Off; end Set_Specific_Warning_Off;
@ -1200,8 +1180,7 @@ package body Erroutc is
Is_Warning_Msg := False; Is_Warning_Msg := False;
Is_Style_Msg := Is_Style_Msg :=
(Msg'Length > 7 (Msg'Length > 7 and then Msg (Msg'First .. Msg'First + 6) = "(style)");
and then Msg (Msg'First .. Msg'First + 6) = "(style)");
if Is_Style_Msg then if Is_Style_Msg then
Is_Serious_Error := False; Is_Serious_Error := False;
@ -1225,7 +1204,7 @@ package body Erroutc is
end if; end if;
end loop; end loop;
if Is_Warning_Msg or else Is_Style_Msg then if Is_Warning_Msg or Is_Style_Msg then
Is_Serious_Error := False; Is_Serious_Error := False;
end if; end if;
end Test_Style_Warning_Serious_Msg; end Test_Style_Warning_Serious_Msg;
@ -1262,22 +1241,73 @@ package body Erroutc is
(Loc : Source_Ptr; (Loc : Source_Ptr;
Msg : String_Ptr) return Boolean Msg : String_Ptr) return Boolean
is is
pragma Assert (Msg'First = 1); function Matches (S : String; P : String) return Boolean;
-- Returns true if the String S patches the pattern P, which can contain
-- wild card chars (*). The entire pattern must match the entire string.
Msglen : constant Natural := Msg'Length; -------------
Patlen : Natural; -- Matches --
-- Length of message -------------
Pattern : String_Ptr; function Matches (S : String; P : String) return Boolean is
-- Pattern itself, excluding initial and final * Slast : constant Natural := S'Last;
PLast : constant Natural := P'Last;
Star_Start : Boolean; SPtr : Natural := S'First;
Star_End : Boolean; PPtr : Natural := P'First;
-- Indications of * at start and end of original pattern
Msgp : Natural; begin
Patp : Natural; -- Loop advancing through characters of string and pattern
-- Scan pointers for message and pattern
SPtr := S'First;
PPtr := P'First;
loop
-- Return True if pattern is a single asterisk
if PPtr = PLast and then P (PPtr) = '*' then
return True;
-- Return True if both pattern and string exhausted
elsif PPtr > PLast and then SPtr > Slast then
return True;
-- Return False, if one exhausted and not the other
elsif PPtr > PLast or else SPtr > Slast then
return False;
-- Case where pattern starts with asterisk
elsif P (PPtr) = '*' then
-- Try all possible starting positions in S for match with
-- the remaining characters of the pattern. This is the
-- recursive call that implements the scanner backup.
for J in SPtr .. Slast loop
if Matches (S (J .. Slast), P (PPtr + 1 .. PLast)) then
return True;
end if;
end loop;
return False;
-- Dealt with end of string and *, advance if we have a match
elsif S (SPtr) = P (PPtr) then
SPtr := SPtr + 1;
PPtr := PPtr + 1;
-- If first characters do not match, that's decisive
else
return False;
end if;
end loop;
end Matches;
-- Start of processing for Warning_Specifically_Suppressed
begin begin
-- Loop through specific warning suppression entries -- Loop through specific warning suppression entries
@ -1293,79 +1323,10 @@ package body Erroutc is
if SWE.Config if SWE.Config
or else (SWE.Start <= Loc and then Loc <= SWE.Stop) or else (SWE.Start <= Loc and then Loc <= SWE.Stop)
then then
-- Check if message matches, dealing with * patterns if Matches (Msg.all, SWE.Msg.all) then
SWE.Used := True;
Patlen := SWE.Patlen; return True;
Pattern := SWE.Pattern; end if;
Star_Start := SWE.Star_Start;
Star_End := SWE.Star_End;
-- Loop through possible starting positions in Msg
Outer : for M in 1 .. 1 + (Msglen - Patlen) loop
-- See if pattern matches string starting at Msg (J)
Msgp := M;
Patp := 1;
Inner : loop
-- If pattern exhausted, then match if we are at end
-- of message, or if pattern ended with an asterisk,
-- otherwise match failure at this position.
if Patp > Patlen then
if Msgp > Msglen or else Star_End then
SWE.Used := True;
return True;
else
exit Inner;
end if;
-- Otherwise if message exhausted (and we still have
-- pattern characters left), then match failure here.
elsif Msgp > Msglen then
exit Inner;
end if;
-- Here we have pattern and message characters left
-- Handle "*" pattern match
if Patp < Patlen - 1 and then
Pattern (Patp .. Patp + 2) = """*"""
then
Patp := Patp + 3;
-- Must have " and at least three chars in msg or we
-- have no match at this position.
exit Inner when Msg (Msgp) /= '"';
Msgp := Msgp + 1;
-- Scan out " string " in message
Scan : loop
exit Inner when Msgp = Msglen;
Msgp := Msgp + 1;
exit Scan when Msg (Msgp - 1) = '"';
end loop Scan;
-- If not "*" case, just compare character
else
exit Inner when Pattern (Patp) /= Msg (Msgp);
Patp := Patp + 1;
Msgp := Msgp + 1;
end if;
end loop Inner;
-- Advance to next position if star at end of original
-- pattern, otherwise no more match attempts are possible
exit Outer when not Star_Start;
end loop Outer;
end if; end if;
end; end;
end loop; end loop;

28
gcc/ada/erroutc.ads
View File

@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2008, 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- --
@ -52,6 +52,7 @@ package Erroutc is
Is_Style_Msg : Boolean := False; Is_Style_Msg : Boolean := False;
-- Set True to indicate if the current message is a style message -- Set True to indicate if the current message is a style message
-- (i.e. a message whose text starts with the cahracters "(style)").
Is_Serious_Error : Boolean := False; Is_Serious_Error : Boolean := False;
-- Set by Set_Msg_Text to indicate if current message is serious error -- Set by Set_Msg_Text to indicate if current message is serious error
@ -267,25 +268,12 @@ package Erroutc is
Msg : String_Ptr; Msg : String_Ptr;
-- Message from pragma Warnings (Off, string) -- Message from pragma Warnings (Off, string)
Pattern : String_Ptr;
-- Same as Msg, excluding initial and final asterisks if present. The
-- lower bound of this string is always one.
Patlen : Natural;
-- Length of pattern string (excluding initial/final asterisks)
Open : Boolean; Open : Boolean;
-- Set to True if OFF has been encountered with no matching ON -- Set to True if OFF has been encountered with no matching ON
Used : Boolean; Used : Boolean;
-- Set to True if entry has been used to suppress a warning -- Set to True if entry has been used to suppress a warning
Star_Start : Boolean;
-- True if given pattern had * at start
Star_End : Boolean;
-- True if given pattern had * at end
Config : Boolean; Config : Boolean;
-- True if pragma is configuration pragma (in which case no matching -- True if pragma is configuration pragma (in which case no matching
-- Off pragma is required, and it is not required that a specific -- Off pragma is required, and it is not required that a specific
@ -482,12 +470,12 @@ package Erroutc is
procedure Test_Style_Warning_Serious_Msg (Msg : String); procedure Test_Style_Warning_Serious_Msg (Msg : String);
-- Sets Is_Warning_Msg true if Msg is a warning message (contains a -- Sets Is_Warning_Msg true if Msg is a warning message (contains a
-- question mark character), and False otherwise. Sets Is_Style_Msg -- question mark character), and False otherwise. Is_Style_Msg is set true
-- true if Msg is a style message (starts with "(style)"). Sets -- if Msg is a style message (starts with "(style)". Sets Is_Serious_Error
-- Is_Serious_Error True unless the message is a warning or style -- True unless the message is a warning or style/info message or contains
-- message or contains the character | indicating a non-serious -- the character | indicating a non-serious error message. Note that the
-- error message. Note that the call has no effect for continuation -- call has no effect for continuation messages (those whose first
-- messages (those whose first character is \). -- character is '\').
function Warnings_Suppressed (Loc : Source_Ptr) return Boolean; function Warnings_Suppressed (Loc : Source_Ptr) return Boolean;
-- Determines if given location is covered by a warnings off suppression -- Determines if given location is covered by a warnings off suppression

367
gcc/ada/sem_elab.adb
View File

@ -58,11 +58,11 @@ with Uname; use Uname;
package body Sem_Elab is package body Sem_Elab is
-- The following table records the recursive call chain for output -- The following table records the recursive call chain for output in the
-- in the Output routine. Each entry records the call node and the -- Output routine. Each entry records the call node and the entity of the
-- entity of the called routine. The number of entries in the table -- called routine. The number of entries in the table (i.e. the value of
-- (i.e. the value of Elab_Call.Last) indicates the current depth -- Elab_Call.Last) indicates the current depth of recursion and is used to
-- of recursion and is used to identify the outer level. -- identify the outer level.
type Elab_Call_Entry is record type Elab_Call_Entry is record
Cloc : Source_Ptr; Cloc : Source_Ptr;
@ -77,10 +77,10 @@ package body Sem_Elab is
Table_Increment => 100, Table_Increment => 100,
Table_Name => "Elab_Call"); Table_Name => "Elab_Call");
-- This table is initialized at the start of each outer level call. -- This table is initialized at the start of each outer level call. It
-- It holds the entities for all subprograms that have been examined -- holds the entities for all subprograms that have been examined for this
-- for this particular outer level call, and is used to prevent both -- particular outer level call, and is used to prevent both infinite
-- infinite recursion, and useless reanalysis of bodies already seen -- recursion, and useless reanalysis of bodies already seen
package Elab_Visited is new Table.Table ( package Elab_Visited is new Table.Table (
Table_Component_Type => Entity_Id, Table_Component_Type => Entity_Id,
@ -127,9 +127,8 @@ package body Sem_Elab is
Table_Name => "Delay_Check"); Table_Name => "Delay_Check");
C_Scope : Entity_Id; C_Scope : Entity_Id;
-- Top level scope of current scope. We need to compute this only -- Top level scope of current scope. Compute this only once at the outer
-- once at the outer level, i.e. for a call to Check_Elab_Call from -- level, i.e. for a call to Check_Elab_Call from outside this unit.
-- outside this unit.
Outer_Level_Sloc : Source_Ptr; Outer_Level_Sloc : Source_Ptr;
-- Save Sloc value for outer level call node for comparisons of source -- Save Sloc value for outer level call node for comparisons of source
@ -149,9 +148,9 @@ package body Sem_Elab is
Delaying_Elab_Checks : Boolean := True; Delaying_Elab_Checks : Boolean := True;
-- This is set True till the compilation is complete, including the -- This is set True till the compilation is complete, including the
-- insertion of all instance bodies. Then when Check_Elab_Calls is -- insertion of all instance bodies. Then when Check_Elab_Calls is called,
-- called, the delay table is used to make the delayed calls and -- the delay table is used to make the delayed calls and this flag is reset
-- this flag is reset to False, so that the calls are processed -- to False, so that the calls are processed
----------------------- -----------------------
-- Local Subprograms -- -- Local Subprograms --
@ -177,16 +176,15 @@ package body Sem_Elab is
Outer_Scope : Entity_Id; Outer_Scope : Entity_Id;
Inter_Unit_Only : Boolean; Inter_Unit_Only : Boolean;
Generate_Warnings : Boolean := True); Generate_Warnings : Boolean := True);
-- This is the internal recursive routine that is called to check for -- This is the internal recursive routine that is called to check for a
-- a possible elaboration error. The argument N is a subprogram call -- possible elaboration error. The argument N is a subprogram call or
-- or generic instantiation to be checked, and E is the entity of -- generic instantiation to be checked, and E is the entity of the called
-- the called subprogram, or instantiated generic unit. The flag -- subprogram, or instantiated generic unit. The flag Outer_Scope is the
-- Outer_Scope is the outer level scope for the original call. -- outer level scope for the original call. Inter_Unit_Only is set if the
-- Inter_Unit_Only is set if the call is only to be checked in the -- call is only to be checked in the case where it is to another unit (and
-- case where it is to another unit (and skipped if within a unit). -- skipped if within a unit). Generate_Warnings is set to False to suppress
-- Generate_Warnings is set to False to suppress warning messages -- warning messages about missing pragma Elaborate_All's. These messages
-- about missing pragma Elaborate_All's. These messages are not -- are not wanted for inner calls in the dynamic model.
-- wanted for inner calls in the dynamic model.
procedure Check_Bad_Instantiation (N : Node_Id); procedure Check_Bad_Instantiation (N : Node_Id);
-- N is a node for an instantiation (if called with any other node kind, -- N is a node for an instantiation (if called with any other node kind,
@ -207,14 +205,14 @@ package body Sem_Elab is
E : Entity_Id; E : Entity_Id;
Outer_Scope : Entity_Id; Outer_Scope : Entity_Id;
Orig_Ent : Entity_Id); Orig_Ent : Entity_Id);
-- N is a function call or procedure statement call node and E is -- N is a function call or procedure statement call node and E is the
-- the entity of the called function, which is within the current -- entity of the called function, which is within the current compilation
-- compilation unit (where subunits count as part of the parent). -- unit (where subunits count as part of the parent). This call checks if
-- This call checks if this call, or any call within any accessed -- this call, or any call within any accessed body could cause an ABE, and
-- body could cause an ABE, and if so, outputs a warning. Orig_Ent -- if so, outputs a warning. Orig_Ent differs from E only in the case of
-- differs from E only in the case of renamings, and points to the -- renamings, and points to the original name of the entity. This is used
-- original name of the entity. This is used for error messages. -- for error messages. Outer_Scope is the outer level scope for the
-- Outer_Scope is the outer level scope for the original call. -- original call.
procedure Check_Internal_Call_Continue procedure Check_Internal_Call_Continue
(N : Node_Id; (N : Node_Id;
@ -224,10 +222,10 @@ package body Sem_Elab is
-- The processing for Check_Internal_Call is divided up into two phases, -- The processing for Check_Internal_Call is divided up into two phases,
-- and this represents the second phase. The second phase is delayed if -- and this represents the second phase. The second phase is delayed if
-- Delaying_Elab_Calls is set to True. In this delayed case, the first -- Delaying_Elab_Calls is set to True. In this delayed case, the first
-- phase makes an entry in the Delay_Check table, which is processed -- phase makes an entry in the Delay_Check table, which is processed when
-- when Check_Elab_Calls is called. N, E and Orig_Ent are as for the call -- Check_Elab_Calls is called. N, E and Orig_Ent are as for the call to
-- to Check_Internal_Call. Outer_Scope is the outer level scope for -- Check_Internal_Call. Outer_Scope is the outer level scope for the
-- the original call. -- original call.
procedure Set_Elaboration_Constraint procedure Set_Elaboration_Constraint
(Call : Node_Id; (Call : Node_Id;
@ -268,16 +266,16 @@ package body Sem_Elab is
-- inevitable, given the optional body semantics of Ada). -- inevitable, given the optional body semantics of Ada).
procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty); procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty);
-- Given code for an elaboration check (or unconditional raise if -- Given code for an elaboration check (or unconditional raise if the check
-- the check is not needed), inserts the code in the appropriate -- is not needed), inserts the code in the appropriate place. N is the call
-- place. N is the call or instantiation node for which the check -- or instantiation node for which the check code is required. C is the
-- code is required. C is the test whose failure triggers the raise. -- test whose failure triggers the raise.
procedure Output_Calls (N : Node_Id); procedure Output_Calls (N : Node_Id);
-- Outputs chain of calls stored in the Elab_Call table. The caller -- Outputs chain of calls stored in the Elab_Call table. The caller has
-- has already generated the main warning message, so the warnings -- already generated the main warning message, so the warnings generated
-- generated are all continuation messages. The argument is the -- are all continuation messages. The argument is the call node at which
-- call node at which the messages are to be placed. -- the messages are to be placed.
function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean; function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean;
-- Given two scopes, determine whether they are the same scope from an -- Given two scopes, determine whether they are the same scope from an
@ -288,17 +286,16 @@ package body Sem_Elab is
-- to be the enclosing compilation unit of this scope. -- to be the enclosing compilation unit of this scope.
function Spec_Entity (E : Entity_Id) return Entity_Id; function Spec_Entity (E : Entity_Id) return Entity_Id;
-- Given a compilation unit entity, if it is a spec entity, it is -- Given a compilation unit entity, if it is a spec entity, it is returned
-- returned unchanged. If it is a body entity, then the spec for -- unchanged. If it is a body entity, then the spec for the corresponding
-- the corresponding spec is returned -- spec is returned
procedure Supply_Bodies (N : Node_Id); procedure Supply_Bodies (N : Node_Id);
-- Given a node, N, that is either a subprogram declaration or a package -- Given a node, N, that is either a subprogram declaration or a package
-- declaration, this procedure supplies dummy bodies for the subprogram -- declaration, this procedure supplies dummy bodies for the subprogram
-- or for all subprograms in the package. If the given node is not one -- or for all subprograms in the package. If the given node is not one
-- of these two possibilities, then Supply_Bodies does nothing. The -- of these two possibilities, then Supply_Bodies does nothing. The
-- dummy body is supplied by setting the subprogram to be Imported with -- dummy body contains a single Raise statement.
-- convention Stubbed.
procedure Supply_Bodies (L : List_Id); procedure Supply_Bodies (L : List_Id);
-- Calls Supply_Bodies for all elements of the given list L -- Calls Supply_Bodies for all elements of the given list L
@ -480,11 +477,10 @@ package body Sem_Elab is
Decl : Node_Id; Decl : Node_Id;
E_Scope : Entity_Id; E_Scope : Entity_Id;
-- Top level scope of entity for called subprogram. This -- Top level scope of entity for called subprogram. This value includes
-- value includes following renamings and derivations, so -- following renamings and derivations, so this scope can be in a
-- this scope can be in a non-visible unit. This is the -- non-visible unit. This is the scope that is to be investigated to
-- scope that is to be investigated to see whether an -- see whether an elaboration check is required.
-- elaboration check is required.
W_Scope : Entity_Id; W_Scope : Entity_Id;
-- Top level scope of directly called entity for subprogram. This -- Top level scope of directly called entity for subprogram. This
@ -531,8 +527,8 @@ package body Sem_Elab is
return; return;
end if; end if;
-- Go to parent for derived subprogram, or to original subprogram -- Go to parent for derived subprogram, or to original subprogram in the
-- in the case of a renaming (Alias covers both these cases) -- case of a renaming (Alias covers both these cases).
Ent := E; Ent := E;
loop loop
@ -646,16 +642,16 @@ package body Sem_Elab is
return; return;
end if; end if;
-- Nothing to do for a generic instance, because in this case -- Nothing to do for a generic instance, because in this case the
-- the checking was at the point of instantiation of the generic -- checking was at the point of instantiation of the generic However,
-- However, this shortcut is only applicable in static mode. -- this shortcut is only applicable in static mode.
if Is_Generic_Instance (Ent) and not Dynamic_Elaboration_Checks then if Is_Generic_Instance (Ent) and not Dynamic_Elaboration_Checks then
return; return;
end if; end if;
-- Nothing to do if subprogram with no separate spec. However, -- Nothing to do if subprogram with no separate spec. However, a
-- a call to Deep_Initialize may result in a call to a user-defined -- call to Deep_Initialize may result in a call to a user-defined
-- Initialize procedure, which imposes a body dependency. This -- Initialize procedure, which imposes a body dependency. This
-- happens only if the type is controlled and the Initialize -- happens only if the type is controlled and the Initialize
-- procedure is not inherited. -- procedure is not inherited.
@ -762,8 +758,8 @@ package body Sem_Elab is
then then
E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller)); E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller));
-- If we don't get a spec entity, just ignore call. Not -- If we don't get a spec entity, just ignore call. Not quite
-- quite clear why this check is necessary. -- clear why this check is necessary. ???
if No (E_Scope) then if No (E_Scope) then
return; return;
@ -775,16 +771,15 @@ package body Sem_Elab is
E_Scope := Scope (E_Scope); E_Scope := Scope (E_Scope);
end loop; end loop;
-- For the case N is not an instance, or a call within instance -- For the case N is not an instance, or a call within instance, we
-- We recompute E_Scope for the error message, since we -- recompute E_Scope for the error message, since we do NOT want to
-- do NOT want to go to the unit which has the ultimate -- go to the unit which has the ultimate declaration in the case of
-- declaration in the case of renaming and derivation and -- renaming and derivation and we also want to go to the generic unit
-- we also want to go to the generic unit in the case of -- in the case of an instance, and no further.
-- an instance, and no further.
else else
-- Loop to carefully follow renamings and derivations -- Loop to carefully follow renamings and derivations one step
-- one step outside the current unit, but not further. -- outside the current unit, but not further.
if not Inst_Case if not Inst_Case
and then Present (Alias (Ent)) and then Present (Alias (Ent))
@ -879,7 +874,7 @@ package body Sem_Elab is
if Inst_Case then if Inst_Case then
Elab_Warning Elab_Warning
("instantiation of& may raise Program_Error?", ("instantiation of& may raise Program_Error?",
"instantiation of& during elaboration?", Ent); "info: instantiation of& during elaboration?", Ent);
else else
if Nkind (Name (N)) in N_Has_Entity if Nkind (Name (N)) in N_Has_Entity
@ -888,13 +883,13 @@ package body Sem_Elab is
then then
Elab_Warning Elab_Warning
("implicit call to & may raise Program_Error?", ("implicit call to & may raise Program_Error?",
"implicit call to & during elaboration?", "info: implicit call to & during elaboration?",
Ent); Ent);
else else
Elab_Warning Elab_Warning
("call to & may raise Program_Error?", ("call to & may raise Program_Error?",
"call to & during elaboration?", "info: call to & during elaboration?",
Ent); Ent);
end if; end if;
end if; end if;
@ -904,12 +899,12 @@ package body Sem_Elab is
if Nkind (N) in N_Subprogram_Instantiation then if Nkind (N) in N_Subprogram_Instantiation then
Elab_Warning Elab_Warning
("\missing pragma Elaborate for&?", ("\missing pragma Elaborate for&?",
"\implicit pragma Elaborate for& generated?", "\info: implicit pragma Elaborate for& generated?",
W_Scope); W_Scope);
else else
Elab_Warning Elab_Warning
("\missing pragma Elaborate_All for&?", ("\missing pragma Elaborate_All for&?",
"\implicit pragma Elaborate_All for & generated?", "\info: implicit pragma Elaborate_All for & generated?",
W_Scope); W_Scope);
end if; end if;
end Generate_Elab_Warnings; end Generate_Elab_Warnings;
@ -936,8 +931,8 @@ package body Sem_Elab is
-- Runtime elaboration check required. Generate check of the -- Runtime elaboration check required. Generate check of the
-- elaboration Boolean for the unit containing the entity. -- elaboration Boolean for the unit containing the entity.
-- Note that for this case, we do check the real unit (the -- Note that for this case, we do check the real unit (the one
-- one from following renamings, since that is the issue!) -- from following renamings, since that is the issue!)
-- Could this possibly miss a useless but required PE??? -- Could this possibly miss a useless but required PE???
@ -952,10 +947,10 @@ package body Sem_Elab is
-- Case of static elaboration model -- Case of static elaboration model
else else
-- Do not do anything if elaboration checks suppressed. Note -- Do not do anything if elaboration checks suppressed. Note that
-- that we check Ent here, not E, since we want the real entity -- we check Ent here, not E, since we want the real entity for the
-- for the body to see if checks are suppressed for it, not the -- body to see if checks are suppressed for it, not the dummy
-- dummy entry for renamings or derivations. -- entry for renamings or derivations.
if Elaboration_Checks_Suppressed (Ent) if Elaboration_Checks_Suppressed (Ent)
or else Elaboration_Checks_Suppressed (E_Scope) or else Elaboration_Checks_Suppressed (E_Scope)
@ -1111,7 +1106,7 @@ package body Sem_Elab is
function Get_Called_Ent return Entity_Id; function Get_Called_Ent return Entity_Id;
-- Retrieve called entity. If this is a call to a protected subprogram, -- Retrieve called entity. If this is a call to a protected subprogram,
-- entity is a selected component. The callable entity may be absent, -- entity is a selected component. The callable entity may be absent,
-- in which case there is no check to perform. This happens with -- in which case there is no check to perform. This happens with
-- non-analyzed calls in nested generics. -- non-analyzed calls in nested generics.
-------------------- --------------------
@ -1201,8 +1196,8 @@ package body Sem_Elab is
-- is at the time of the actual call (statically speaking) that we must -- is at the time of the actual call (statically speaking) that we must
-- do our static check, not at the time of its initial analysis). -- do our static check, not at the time of its initial analysis).
-- However, we have to check calls within component definitions (e.g., a -- However, we have to check calls within component definitions (e.g.
-- function call that determines an array component bound), so we -- a function call that determines an array component bound), so we
-- terminate the loop in that case. -- terminate the loop in that case.
P := Parent (N); P := Parent (N);
@ -1229,8 +1224,8 @@ package body Sem_Elab is
if No (Outer_Scope) then if No (Outer_Scope) then
Elab_Visited.Set_Last (0); Elab_Visited.Set_Last (0);
-- Nothing to do if current scope is Standard (this is a bit -- Nothing to do if current scope is Standard (this is a bit odd, but
-- odd, but it happens in the case of generic instantiations). -- it happens in the case of generic instantiations).
C_Scope := Current_Scope; C_Scope := Current_Scope;
@ -1243,9 +1238,8 @@ package body Sem_Elab is
From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit;
if From_Elab_Code then if From_Elab_Code then
-- Complain if call that comes from source in preelaborated -- Complain if call that comes from source in preelaborated unit
-- unit and we are not inside a subprogram (i.e. we are in -- and we are not inside a subprogram (i.e. we are in elab code).
-- elab code)
if Comes_From_Source (N) if Comes_From_Source (N)
and then In_Preelaborated_Unit and then In_Preelaborated_Unit
@ -1456,9 +1450,9 @@ package body Sem_Elab is
-- A call to an Init_Proc in elaboration code may bring additional -- A call to an Init_Proc in elaboration code may bring additional
-- dependencies, if some of the record components thereof have -- dependencies, if some of the record components thereof have
-- initializations that are function calls that come from source. -- initializations that are function calls that come from source. We
-- We treat the current node as a call to each of these functions, -- treat the current node as a call to each of these functions, to check
-- to check their elaboration impact. -- their elaboration impact.
if Is_Init_Proc (Ent) if Is_Init_Proc (Ent)
and then From_Elab_Code and then From_Elab_Code
@ -1521,9 +1515,9 @@ package body Sem_Elab is
Pkg_Body : Entity_Id; Pkg_Body : Entity_Id;
begin begin
-- For record or array component, check prefix. If it is an access -- For record or array component, check prefix. If it is an access type,
-- type, then there is nothing to do (we do not know what is being -- then there is nothing to do (we do not know what is being assigned),
-- assigned), but otherwise this is an assignment to the prefix. -- but otherwise this is an assignment to the prefix.
if Nkind (N) = N_Indexed_Component if Nkind (N) = N_Indexed_Component
or else or else
@ -1712,10 +1706,10 @@ package body Sem_Elab is
procedure Check_Elab_Calls is procedure Check_Elab_Calls is
begin begin
-- If expansion is disabled, do not generate any checks. Also -- If expansion is disabled, do not generate any checks. Also skip
-- skip checks if any subunits are missing because in either -- checks if any subunits are missing because in either case we lack the
-- case we lack the full information that we need, and no object -- full information that we need, and no object file will be created in
-- file will be created in any case. -- any case.
if not Expander_Active if not Expander_Active
or else Is_Generic_Unit (Cunit_Entity (Main_Unit)) or else Is_Generic_Unit (Cunit_Entity (Main_Unit))
@ -1822,11 +1816,11 @@ package body Sem_Elab is
Set_C_Scope; Set_C_Scope;
Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False);
-- If none of those cases holds, but Dynamic_Elaboration_Checks mode -- If none of those cases holds, but Dynamic_Elaboration_Checks mode is
-- is set, then we will do the check, but only in the inter-unit case -- set, then we will do the check, but only in the inter-unit case (this
-- (this is to accommodate unguarded elaboration calls from other units -- is to accommodate unguarded elaboration calls from other units in
-- in which this same mode is set). We inhibit warnings in this case, -- which this same mode is set). We inhibit warnings in this case, since
-- since this instantiation is not occurring in elaboration code. -- this instantiation is not occurring in elaboration code.
elsif Dynamic_Elaboration_Checks then elsif Dynamic_Elaboration_Checks then
Set_C_Scope; Set_C_Scope;
@ -1882,10 +1876,10 @@ package body Sem_Elab is
elsif not Full_Analysis then elsif not Full_Analysis then
return; return;
-- Nothing to do if within a default expression, since the call -- Nothing to do if analyzing in special spec-expression mode, since the
-- is not actualy being made at this time. -- call is not actualy being made at this time.
elsif In_Default_Expression then elsif In_Spec_Expression then
return; return;
-- Nothing to do for call to intrinsic subprogram -- Nothing to do for call to intrinsic subprogram
@ -1991,16 +1985,16 @@ package body Sem_Elab is
Check_Elab_Instantiation (N, Outer_Scope); Check_Elab_Instantiation (N, Outer_Scope);
return OK; return OK;
-- Skip subprogram bodies that come from source (wait for -- Skip subprogram bodies that come from source (wait for call to
-- call to analyze these). The reason for the come from -- analyze these). The reason for the come from source test is to
-- source test is to avoid catching task bodies. -- avoid catching task bodies.
-- For task bodies, we should really avoid these too, waiting -- For task bodies, we should really avoid these too, waiting for the
-- for the task activation, but that's too much trouble to -- task activation, but that's too much trouble to catch for now, so
-- catch for now, so we go in unconditionally. This is not -- we go in unconditionally. This is not so terrible, it means the
-- so terrible, it means the error backtrace is not quite -- error backtrace is not quite complete, and we are too eager to
-- complete, and we are too eager to scan bodies of tasks -- scan bodies of tasks that are unused, but this is hardly very
-- that are unused, but this is hardly very significant! -- significant!
elsif Nkind (N) = N_Subprogram_Body elsif Nkind (N) = N_Subprogram_Body
and then Comes_From_Source (N) and then Comes_From_Source (N)
@ -2051,8 +2045,8 @@ package body Sem_Elab is
end if; end if;
end if; end if;
-- If the body appears after the outer level call or -- If the body appears after the outer level call or instantiation then
-- instantiation then we have an error case handled below. -- we have an error case handled below.
if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody)) if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody))
and then not In_Task_Activation and then not In_Task_Activation
@ -2065,8 +2059,8 @@ package body Sem_Elab is
elsif Inst_Case then elsif Inst_Case then
return; return;
-- Otherwise we have a call, so we trace through the called -- Otherwise we have a call, so we trace through the called body to see
-- body to see if it has any problems .. -- if it has any problems.
else else
pragma Assert (Nkind (Sbody) = N_Subprogram_Body); pragma Assert (Nkind (Sbody) = N_Subprogram_Body);
@ -2083,9 +2077,9 @@ package body Sem_Elab is
Write_Eol; Write_Eol;
end if; end if;
-- Now traverse declarations and statements of subprogram body. -- Now traverse declarations and statements of subprogram body. Note
-- Note that we cannot simply Traverse (Sbody), since traverse -- that we cannot simply Traverse (Sbody), since traverse does not
-- does not normally visit subprogram bodies. -- normally visit subprogram bodies.
declare declare
Decl : Node_Id; Decl : Node_Id;
@ -2103,11 +2097,11 @@ package body Sem_Elab is
return; return;
end if; end if;
-- Here is the case of calling a subprogram where the body has -- Here is the case of calling a subprogram where the body has not yet
-- not yet been encountered, a warning message is needed. -- been encountered, a warning message is needed.
-- If we have nothing in the call stack, then this is at the -- If we have nothing in the call stack, then this is at the outer
-- outer level, and the ABE is bound to occur. -- level, and the ABE is bound to occur.
if Elab_Call.Last = 0 then if Elab_Call.Last = 0 then
if Inst_Case then if Inst_Case then
@ -2477,8 +2471,8 @@ package body Sem_Elab is
and then Present (Parameter_Associations (Call)) and then Present (Parameter_Associations (Call))
and then Is_Controlled (Etype (First_Actual (Call))); and then Is_Controlled (Etype (First_Actual (Call)));
begin begin
-- If the unit is mentioned in a with_clause of the current -- If the unit is mentioned in a with_clause of the current unit, it is
-- unit, it is visible, and we can set the elaboration flag. -- visible, and we can set the elaboration flag.
if Is_Immediately_Visible (Scop) if Is_Immediately_Visible (Scop)
or else (Is_Child_Unit (Scop) and then Is_Visible_Child_Unit (Scop)) or else (Is_Child_Unit (Scop) and then Is_Visible_Child_Unit (Scop))
@ -2505,9 +2499,9 @@ package body Sem_Elab is
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
-- unit that is, on which we need to place to elaboration flag. This -- that is, on which we need to place to elaboration flag. This happens
-- happens with init proc calls. -- with init proc calls.
if Is_Init_Proc (Subp) if Is_Init_Proc (Subp)
or else Init_Call or else Init_Call
@ -2561,30 +2555,29 @@ package body Sem_Elab is
function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id; function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id;
-- Determine if the list of nodes headed by N and linked by Next -- Determine if the list of nodes headed by N and linked by Next
-- contains a package body for the package spec entity E, and if -- contains a package body for the package spec entity E, and if so
-- so return the package body. If not, then returns Empty. -- return the package body. If not, then returns Empty.
function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id; function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id;
-- This procedure is called load the unit whose name is given by Nam. -- This procedure is called load the unit whose name is given by Nam.
-- This unit is being loaded to see whether it contains an optional -- This unit is being loaded to see whether it contains an optional
-- generic body. The returned value is the loaded unit, which is -- generic body. The returned value is the loaded unit, which is always
-- always a package body (only package bodies can contain other -- a package body (only package bodies can contain other entities in the
-- entities in the sense in which Has_Generic_Body is interested). -- sense in which Has_Generic_Body is interested). We only attempt to
-- We only attempt to load bodies if we are generating code. If we -- load bodies if we are generating code. If we are in semantics check
-- are in semantics check only mode, then it would be wrong to load -- only mode, then it would be wrong to load bodies that are not
-- bodies that are not required from a semantic point of view, so -- required from a semantic point of view, so in this case we return
-- in this case we return Empty. The result is that the caller may -- Empty. The result is that the caller may incorrectly decide that a
-- incorrectly decide that a generic spec does not have a body when -- generic spec does not have a body when in fact it does, but the only
-- in fact it does, but the only harm in this is that some warnings -- harm in this is that some warnings on elaboration problems may be
-- on elaboration problems may be lost in semantic checks only mode, -- lost in semantic checks only mode, which is not big loss. We also
-- which is not big loss. We also return Empty if we go for a body -- return Empty if we go for a body and it is not there.
-- and it is not there.
function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id; function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id;
-- PE is the entity for a package spec. This function locates the -- PE is the entity for a package spec. This function locates the
-- corresponding package body, returning Empty if none is found. -- corresponding package body, returning Empty if none is found. The
-- The package body returned is fully parsed but may not yet be -- package body returned is fully parsed but may not yet be analyzed,
-- analyzed, so only syntactic fields should be referenced. -- so only syntactic fields should be referenced.
------------------ ------------------
-- Find_Body_In -- -- Find_Body_In --
@ -2666,17 +2659,17 @@ package body Sem_Elab is
begin begin
if Is_Library_Level_Entity (PE) then if Is_Library_Level_Entity (PE) then
-- If package is a library unit that requires a body, we have -- If package is a library unit that requires a body, we have no
-- no choice but to go after that body because it might contain -- choice but to go after that body because it might contain an
-- an optional body for the original generic package. -- optional body for the original generic package.
if Unit_Requires_Body (PE) then if Unit_Requires_Body (PE) then
-- Load the body. Note that we are a little careful here to -- Load the body. Note that we are a little careful here to use
-- use Spec to get the unit number, rather than PE or Decl, -- Spec to get the unit number, rather than PE or Decl, since
-- since in the case where the package is itself a library -- in the case where the package is itself a library level
-- level instantiation, Spec will properly reference the -- instantiation, Spec will properly reference the generic
-- generic template, which is what we really want. -- template, which is what we really want.
return return
Load_Package_Body Load_Package_Body
@ -3041,8 +3034,55 @@ package body Sem_Elab is
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_Convention (Ent, Convention_Stubbed); -- Internal subprograms will already have a generated body, so
-- there is no need to provide a stub for them.
if No (Corresponding_Body (N)) then
declare
Loc : constant Source_Ptr := Sloc (N);
B : Node_Id;
Formals : constant List_Id :=
Copy_Parameter_List (Ent);
Nam : constant Entity_Id :=
Make_Defining_Identifier (Loc, Chars (Ent));
Spec : Node_Id;
Stats : constant List_Id :=
New_List
(Make_Raise_Program_Error (Loc,
Reason => PE_Access_Before_Elaboration));
begin
if Ekind (Ent) = E_Function then
Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => Nam,
Parameter_Specifications => Formals,
Result_Definition =>
New_Copy_Tree
(Result_Definition (Specification (N))));
-- We cannot reliably make a return statement for this
-- body, but none is needed because the call raises
-- program error.
Set_Return_Present (Ent);
else
Spec :=
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Nam,
Parameter_Specifications => Formals);
end if;
B := Make_Subprogram_Body (Loc,
Specification => Spec,
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Stats));
Insert_After (N, B);
Analyze (B);
end;
end if;
end; end;
elsif Nkind (N) = N_Package_Declaration then elsif Nkind (N) = N_Package_Declaration then
@ -3075,22 +3115,17 @@ package body Sem_Elab is
function Within (E1, E2 : Entity_Id) return Boolean is function Within (E1, E2 : Entity_Id) return Boolean is
Scop : Entity_Id; Scop : Entity_Id;
begin begin
Scop := E1; Scop := E1;
loop loop
if Scop = E2 then if Scop = E2 then
return True; return True;
elsif Scop = Standard_Standard then elsif Scop = Standard_Standard then
return False; return False;
else else
Scop := Scope (Scop); Scop := Scope (Scop);
end if; end if;
end loop; end loop;
raise Program_Error;
end Within; end Within;
-------------------------- --------------------------