mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-23 06:20:25 +08:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
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 --
-- --
-- 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 --
-- 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)
-- The character ? appearing anywhere in a message makes the message
-- warning instead of a normal error message, and the text of the
-- message will be preceded by "Warning:" instead of "Error:" in the
-- normal case. The handling of warnings if further controlled by the
-- Warning_Mode option (-w switch), see package Opt for further
-- details, and also by the current setting from pragma Warnings. This
-- pragma applies only to warnings issued from the semantic phase (not
-- the parser), but currently all relevant warnings are posted by the
-- semantic phase anyway. Messages starting with (style) are also
-- treated as warning messages.
-- message will be preceded by "warning:" in the normal case. The
-- handling of warnings if further controlled by the Warning_Mode
-- option (-w switch), see package Opt for further details, and also by
-- the current setting from pragma Warnings. This pragma applies only
-- to warnings issued from the semantic phase (not the parser), but
-- currently all relevant warnings are posted by the semantic phase
-- anyway. Messages starting with (style) are also treated as warning
-- 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.
-- messages starting with the \ insertion character). The warning

301
gcc/ada/erroutc.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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 --
-- 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
Warnings_Detected := Warnings_Detected - 1;
else
Total_Errors_Detected := Total_Errors_Detected - 1;
@ -441,6 +442,12 @@ package body Erroutc is
Length : Nat;
-- 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
if Error_Msg_Line_Length = 0 then
Length := Nat'Last;
@ -450,13 +457,21 @@ package body Erroutc is
Max := Integer (Length - Column + 1);
-- For warning message, add "warning: " unless msg starts with "info: "
if Errors.Table (E).Warn then
Write_Str ("warning: ");
Max := Max - 9;
if Len < 6 or else Txt (Txt'First .. Txt'First + 5) /= "info: " then
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
null;
-- All other cases, add "error: "
elsif Opt.Unique_Error_Tag then
Write_Str ("error: ");
Max := Max - 7;
@ -464,74 +479,65 @@ package body Erroutc is
-- Here we have to split the message up into multiple lines
declare
Txt : constant String_Ptr := Errors.Table (E).Text;
Len : constant Natural := Txt'Length;
Ptr : Natural;
Split : Natural;
Start : Natural;
Ptr := 1;
loop
-- Make sure we do not have ludicrously small line
begin
Ptr := 1;
loop
-- Make sure we do not have ludicrously small line
Max := Integer'Max (Max, 20);
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
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;
return;
-- Line does not fit
else
Start := Ptr;
else
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
if Txt (Scan) = ASCII.LF then
Split := Scan - 1;
Ptr := Scan + 1;
goto Continue;
end if;
end loop;
for Scan in Ptr .. Ptr + Max - 1 loop
if Txt (Scan) = ASCII.LF then
Split := Scan - 1;
Ptr := Scan + 1;
goto Continue;
end if;
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
if Txt (Scan) = ' ' then
Split := Scan - 1;
Ptr := Scan + 1;
goto Continue;
end if;
end loop;
for Scan in reverse Ptr .. Ptr + Max - 1 loop
if Txt (Scan) = ' ' then
Split := Scan - 1;
Ptr := Scan + 1;
goto Continue;
end if;
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;
Ptr := Split + 1;
end if;
Split := Ptr + Max - 1;
Ptr := Split + 1;
end if;
<<Continue>>
if Start <= Split then
Write_Line (Txt (Start .. Split));
Write_Spaces (Offs);
end if;
if Start <= Split then
Write_Line (Txt (Start .. Split));
Write_Spaces (Offs);
end if;
Max := Integer (Length - Column + 1);
end loop;
end;
Max := Integer (Length - Column + 1);
end loop;
end Output_Msg_Text;
--------------------
@ -557,6 +563,7 @@ package body Erroutc is
then
if Errors.Table (E).Warn or Errors.Table (E).Style then
Warnings_Detected := Warnings_Detected - 1;
else
Total_Errors_Detected := Total_Errors_Detected - 1;
@ -1052,40 +1059,13 @@ package body Erroutc is
Msg : String;
Config : Boolean)
is
pragma Assert (Msg'First = 1);
Pattern : String := Msg;
Patlen : Natural := Msg'Length;
Star_Start : Boolean;
Star_End : Boolean;
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
((Start => Loc,
Msg => new String'(Msg),
Pattern => new String'(Pattern (1 .. Patlen)),
Patlen => Patlen,
Stop => Source_Last (Current_Source_File),
Open => True,
Used => False,
Star_Start => Star_Start,
Star_End => Star_End,
Config => Config));
end Set_Specific_Warning_Off;
@ -1200,8 +1180,7 @@ package body Erroutc is
Is_Warning_Msg := False;
Is_Style_Msg :=
(Msg'Length > 7
and then Msg (Msg'First .. Msg'First + 6) = "(style)");
(Msg'Length > 7 and then Msg (Msg'First .. Msg'First + 6) = "(style)");
if Is_Style_Msg then
Is_Serious_Error := False;
@ -1225,7 +1204,7 @@ package body Erroutc is
end if;
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;
end if;
end Test_Style_Warning_Serious_Msg;
@ -1262,22 +1241,73 @@ package body Erroutc is
(Loc : Source_Ptr;
Msg : String_Ptr) return Boolean
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;
-- Length of message
-------------
-- Matches --
-------------
Pattern : String_Ptr;
-- Pattern itself, excluding initial and final *
function Matches (S : String; P : String) return Boolean is
Slast : constant Natural := S'Last;
PLast : constant Natural := P'Last;
Star_Start : Boolean;
Star_End : Boolean;
-- Indications of * at start and end of original pattern
SPtr : Natural := S'First;
PPtr : Natural := P'First;
Msgp : Natural;
Patp : Natural;
-- Scan pointers for message and pattern
begin
-- Loop advancing through characters of string 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
-- Loop through specific warning suppression entries
@ -1293,79 +1323,10 @@ package body Erroutc is
if SWE.Config
or else (SWE.Start <= Loc and then Loc <= SWE.Stop)
then
-- Check if message matches, dealing with * patterns
Patlen := SWE.Patlen;
Pattern := SWE.Pattern;
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;
if Matches (Msg.all, SWE.Msg.all) then
SWE.Used := True;
return True;
end if;
end if;
end;
end loop;

28
gcc/ada/erroutc.ads
View File

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