Skip to content

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

errout.ads, errout.adb (Fix Error_Msg_F): Fix implementation to meet spec. 

2005-09-01  Robert Dewar  <dewar@adacore.com>

	* errout.ads, errout.adb (Fix Error_Msg_F): Fix implementation to meet
	spec.
	Implement new insertion char < (conditional warning)
	* errutil.adb, erroutc.adb: Implement new insertion char <
	(conditional warning).
	* sem_elab.adb, prj-dect.adb, erroutc.ads, err_vars.ads
	(Error_Msg_Warn): New variable for < insertion char.
	* prj-nmsc.adb: Implement new errout insertion char < (conditional
	warning).
	(Check_For_Source): Change value of Source_Id only after the current
	source has been dealt with.

From-SVN: r103859
parent 405e57ad
Showing with 123 additions and 113 deletions
gcc/ada/err_vars.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2002 Free Software Foundation, Inc. -- -- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -103,6 +103,10 @@ package Err_Vars is ...@@ -103,6 +103,10 @@ package Err_Vars is
-- note get reset by any Error_Msg call, so the caller is responsible -- note get reset by any Error_Msg call, so the caller is responsible
-- for resetting it. -- for resetting it.
Error_Msg_Warn : Boolean;
-- Used if current message contains a < insertion character to indicate
-- if the current message is a warning message.
Warn_On_Instance : Boolean := False; Warn_On_Instance : Boolean := False;
-- Normally if a warning is generated in a generic template from the -- Normally if a warning is generated in a generic template from the
-- analysis of the template, then the warning really belongs in the -- analysis of the template, then the warning really belongs in the
......
gcc/ada/errout.adb
...@@ -49,7 +49,6 @@ with Sinfo; use Sinfo; ...@@ -49,7 +49,6 @@ with Sinfo; use Sinfo;
with Snames; use Snames; with Snames; use Snames;
with Stand; use Stand; with Stand; use Stand;
with Style; with Style;
with Uintp; use Uintp;
with Uname; use Uname; with Uname; use Uname;
with Unchecked_Conversion; with Unchecked_Conversion;
...@@ -322,14 +321,13 @@ package body Errout is ...@@ -322,14 +321,13 @@ package body Errout is
return; return;
end if; end if;
-- The idea at this stage is that we have two kinds of messages. -- The idea at this stage is that we have two kinds of messages
-- First, we have those that are to be placed as requested at -- First, we have those messages that are to be placed as requested at
-- Flag_Location. This includes messages that have nothing to -- Flag_Location. This includes messages that have nothing to do with
-- do with generics, and also messages placed on generic templates -- generics, and also messages placed on generic templates that reflect
-- that reflect an error in the template itself. For such messages -- an error in the template itself. For such messages we simply call
-- we simply call Error_Msg_Internal to place the message in the -- Error_Msg_Internal to place the message in the requested location.
-- requested location.
if Instantiation (Sindex) = No_Location then if Instantiation (Sindex) = No_Location then
Error_Msg_Internal (Msg, Flag_Location, Flag_Location, False); Error_Msg_Internal (Msg, Flag_Location, Flag_Location, False);
...@@ -606,7 +604,7 @@ package body Errout is ...@@ -606,7 +604,7 @@ package body Errout is
procedure Error_Msg_F (Msg : String; N : Node_Id) is procedure Error_Msg_F (Msg : String; N : Node_Id) is
begin begin
Error_Msg_NEL (Msg, N, N, First_Sloc (N)); Error_Msg_NEL (Msg, N, N, Sloc (First_Node (N)));
end Error_Msg_F; end Error_Msg_F;
------------------ ------------------
...@@ -1613,7 +1611,7 @@ package body Errout is ...@@ -1613,7 +1611,7 @@ package body Errout is
procedure Remove_Warning_Messages (N : Node_Id) is procedure Remove_Warning_Messages (N : Node_Id) is
function Check_For_Warning (N : Node_Id) return Traverse_Result; function Check_For_Warning (N : Node_Id) return Traverse_Result;
-- This function checks one node for a possible warning message. -- This function checks one node for a possible warning message
function Check_All_Warnings is new function Check_All_Warnings is new
Traverse_Func (Check_For_Warning); Traverse_Func (Check_For_Warning);
...@@ -2253,6 +2251,9 @@ package body Errout is ...@@ -2253,6 +2251,9 @@ package body Errout is
when '?' => when '?' =>
null; -- already dealt with null; -- already dealt with
when '<' =>
null; -- already dealt with
when '|' => when '|' =>
null; -- already dealt with null; -- already dealt with
......
gcc/ada/errout.ads
...@@ -243,6 +243,12 @@ package Errout is ...@@ -243,6 +243,12 @@ package Errout is
-- phase anyway. Messages starting with (style) are also treated as -- phase anyway. Messages starting with (style) are also treated as
-- warning messages. -- warning messages.
-- Insertion character < (Less Than: conditional warning message)
-- The character < appearing anywhere in a message is used for a
-- conditional error message. If Error_Msg_Warn is True, then the
-- effect is the same as ? described above. If Error_Msg_Warn is
-- False, then there is no effect.
-- Insertion character A-Z (Upper case letter: Ada reserved word) -- Insertion character A-Z (Upper case letter: Ada reserved word)
-- If two or more upper case letters appear in the message, they are -- If two or more upper case letters appear in the message, they are
-- taken as an Ada reserved word, and are converted to the default -- taken as an Ada reserved word, and are converted to the default
...@@ -358,6 +364,10 @@ package Errout is ...@@ -358,6 +364,10 @@ package Errout is
-- note get reset by any Error_Msg call, so the caller is responsible -- note get reset by any Error_Msg call, so the caller is responsible
-- for resetting it. -- for resetting it.
Error_Msg_Warn : Boolean renames Err_Vars.Error_Msg_Warn;
-- Used if current message contains a < insertion character to indicate
-- if the current message is a warning message.
----------------------------------------------------- -----------------------------------------------------
-- Format of Messages and Manual Quotation Control -- -- Format of Messages and Manual Quotation Control --
----------------------------------------------------- -----------------------------------------------------
...@@ -440,7 +450,7 @@ package Errout is ...@@ -440,7 +450,7 @@ package Errout is
function Get_Location (E : Error_Msg_Id) return Source_Ptr function Get_Location (E : Error_Msg_Id) return Source_Ptr
renames Erroutc.Get_Location; renames Erroutc.Get_Location;
-- Returns the flag location of the error message with the given id E. -- Returns the flag location of the error message with the given id E
------------------------ ------------------------
-- List Pragmas Table -- -- List Pragmas Table --
...@@ -601,7 +611,7 @@ package Errout is ...@@ -601,7 +611,7 @@ package Errout is
-- of its descendent nodes. No effect if no such warnings. -- of its descendent nodes. No effect if no such warnings.
procedure Remove_Warning_Messages (L : List_Id); procedure Remove_Warning_Messages (L : List_Id);
-- Remove warnings on all elements of a list. -- Remove warnings on all elements of a list
procedure Set_Ignore_Errors (To : Boolean); procedure Set_Ignore_Errors (To : Boolean);
-- Following a call to this procedure with To=True, all error calls are -- Following a call to this procedure with To=True, all error calls are
......
gcc/ada/erroutc.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- -- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -40,7 +40,6 @@ with Sinput; use Sinput; ...@@ -40,7 +40,6 @@ with Sinput; use Sinput;
with Snames; use Snames; with Snames; use Snames;
with Targparm; use Targparm; with Targparm; use Targparm;
with Table; with Table;
with Types; use Types;
with Uintp; use Uintp; with Uintp; use Uintp;
package body Erroutc is package body Erroutc is
...@@ -983,6 +982,11 @@ package body Erroutc is ...@@ -983,6 +982,11 @@ package body Erroutc is
then then
Is_Warning_Msg := True; Is_Warning_Msg := True;
elsif Msg (J) = '<'
and then (J = Msg'First or else Msg (J - 1) /= ''')
then
Is_Warning_Msg := Error_Msg_Warn;
elsif Msg (J) = '|' elsif Msg (J) = '|'
and then (J = Msg'First or else Msg (J - 1) /= ''') and then (J = Msg'First or else Msg (J - 1) /= ''')
then then
......
gcc/ada/erroutc.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- -- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -28,7 +28,7 @@ ...@@ -28,7 +28,7 @@
-- reporting packages, including Errout and Prj.Err. -- reporting packages, including Errout and Prj.Err.
with Table; with Table;
with Types; use Types; with Types; use Types;
package Erroutc is package Erroutc is
...@@ -122,7 +122,7 @@ package Erroutc is ...@@ -122,7 +122,7 @@ package Erroutc is
-- Error_Msg routines. -- Error_Msg routines.
function Get_Location (E : Error_Msg_Id) return Source_Ptr; function Get_Location (E : Error_Msg_Id) return Source_Ptr;
-- Returns the flag location of the error message with the given id E. -- Returns the flag location of the error message with the given id E
----------------------------------- -----------------------------------
-- Error Message Data Structures -- -- Error Message Data Structures --
...@@ -332,7 +332,7 @@ package Erroutc is ...@@ -332,7 +332,7 @@ package Erroutc is
-- Handle name insertion (% insertion character) -- Handle name insertion (% insertion character)
procedure Set_Msg_Insertion_Reserved_Name; procedure Set_Msg_Insertion_Reserved_Name;
-- Handle insertion of reserved word name (* insertion character). -- Handle insertion of reserved word name (* insertion character)
procedure Set_Msg_Insertion_Reserved_Word procedure Set_Msg_Insertion_Reserved_Word
(Text : String; (Text : String;
......
gcc/ada/errutil.adb
...@@ -44,7 +44,7 @@ package body Errutil is ...@@ -44,7 +44,7 @@ package body Errutil is
----------------------- -----------------------
procedure Error_Msg_AP (Msg : String); procedure Error_Msg_AP (Msg : String);
-- Output a message just after the previous token. -- Output a message just after the previous token
procedure Output_Source_Line procedure Output_Source_Line
(L : Physical_Line_Number; (L : Physical_Line_Number;
...@@ -184,12 +184,12 @@ package body Errutil is ...@@ -184,12 +184,12 @@ package body Errutil is
return; return;
end if; end if;
-- Return without doing anything if message is killed and this -- Return without doing anything if message is killed and this is not
-- is not the first error message. The philosophy is that if we -- the first error message. The philosophy is that if we get a weird
-- get a weird error message and we already have had a message, -- error message and we already have had a message, then we hope the
-- then we hope the weird message is a junk cascaded message -- weird message is a junk cascaded message
-- Immediate return if warning message and warnings are suppressed -- Immediate return if warning message and warnings are suppressed.
-- Note that style messages are not warnings for this purpose. -- Note that style messages are not warnings for this purpose.
if Is_Warning_Msg and then Warnings_Suppressed (Sptr) then if Is_Warning_Msg and then Warnings_Suppressed (Sptr) then
...@@ -246,20 +246,19 @@ package body Errutil is ...@@ -246,20 +246,19 @@ package body Errutil is
and then Errors.Table (Prev_Msg).Sfile = and then Errors.Table (Prev_Msg).Sfile =
Errors.Table (Cur_Msg).Sfile Errors.Table (Cur_Msg).Sfile
then then
-- Don't delete unconditional messages and at this stage, -- Don't delete unconditional messages and at this stage, don't
-- don't delete continuation lines (we attempted to delete -- delete continuation lines (we attempted to delete those earlier
-- those earlier if the parent message was deleted. -- if the parent message was deleted.
if not Errors.Table (Cur_Msg).Uncond if not Errors.Table (Cur_Msg).Uncond
and then not Continuation and then not Continuation
then then
-- Don't delete if prev msg is warning and new msg is -- Don't delete if prev msg is warning and new msg is an error.
-- an error. This is because we don't want a real error -- This is because we don't want a real error masked by a warning.
-- masked by a warning. In all other cases (that is parse -- In all other cases (that is parse errors for the same line that
-- errors for the same line that are not unconditional) -- are not unconditional) we do delete the message. This helps to
-- we do delete the message. This helps to avoid -- avoid junk extra messages from cascaded parsing errors
-- junk extra messages from cascaded parsing errors
if not (Errors.Table (Prev_Msg).Warn if not (Errors.Table (Prev_Msg).Warn
or or
...@@ -269,8 +268,8 @@ package body Errutil is ...@@ -269,8 +268,8 @@ package body Errutil is
or or
Errors.Table (Cur_Msg).Style) Errors.Table (Cur_Msg).Style)
then then
-- All tests passed, delete the message by simply -- All tests passed, delete the message by simply returning
-- returning without any further processing. -- without any further processing.
if not Continuation then if not Continuation then
Last_Killed := True; Last_Killed := True;
...@@ -438,7 +437,6 @@ package body Errutil is ...@@ -438,7 +437,6 @@ package body Errutil is
Write_Eol; Write_Eol;
end if; end if;
end loop; end loop;
-- Then output errors, if any, for subsidiary units -- Then output errors, if any, for subsidiary units
...@@ -564,7 +562,6 @@ package body Errutil is ...@@ -564,7 +562,6 @@ package body Errutil is
Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected; Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected;
Warnings_Detected := 0; Warnings_Detected := 0;
end if; end if;
end Finalize; end Finalize;
---------------- ----------------
...@@ -585,7 +582,6 @@ package body Errutil is ...@@ -585,7 +582,6 @@ package body Errutil is
-- an initial dummy entry covering all possible source locations. -- an initial dummy entry covering all possible source locations.
Warnings.Init; Warnings.Init;
end Initialize; end Initialize;
------------------------ ------------------------
...@@ -682,6 +678,7 @@ package body Errutil is ...@@ -682,6 +678,7 @@ package body Errutil is
Set_Msg_Insertion_Name; Set_Msg_Insertion_Name;
elsif C = '$' then elsif C = '$' then
-- '$' is ignored -- '$' is ignored
null; null;
...@@ -690,6 +687,7 @@ package body Errutil is ...@@ -690,6 +687,7 @@ package body Errutil is
Set_Msg_Insertion_File_Name; Set_Msg_Insertion_File_Name;
elsif C = '}' then elsif C = '}' then
-- '}' is ignored -- '}' is ignored
null; null;
...@@ -698,6 +696,7 @@ package body Errutil is ...@@ -698,6 +696,7 @@ package body Errutil is
Set_Msg_Insertion_Reserved_Name; Set_Msg_Insertion_Reserved_Name;
elsif C = '&' then elsif C = '&' then
-- '&' is ignored -- '&' is ignored
null; null;
...@@ -724,6 +723,9 @@ package body Errutil is ...@@ -724,6 +723,9 @@ package body Errutil is
elsif C = '?' then elsif C = '?' then
null; null;
elsif C = '<' then
null;
elsif C = '|' then elsif C = '|' then
null; null;
......
gcc/ada/prj-dect.adb
...@@ -30,9 +30,7 @@ with Opt; use Opt; ...@@ -30,9 +30,7 @@ with Opt; use Opt;
with Prj.Err; use Prj.Err; with Prj.Err; use Prj.Err;
with Prj.Strt; use Prj.Strt; with Prj.Strt; use Prj.Strt;
with Prj.Tree; use Prj.Tree; with Prj.Tree; use Prj.Tree;
with Scans; use Scans;
with Snames; with Snames;
with Types; use Types;
with Prj.Attr; use Prj.Attr; with Prj.Attr; use Prj.Attr;
with Prj.Attr.PM; use Prj.Attr.PM; with Prj.Attr.PM; use Prj.Attr.PM;
with Uintp; use Uintp; with Uintp; use Uintp;
...@@ -212,13 +210,8 @@ package body Prj.Dect is ...@@ -212,13 +210,8 @@ package body Prj.Dect is
end if; end if;
Error_Msg_Name_1 := Token_Name; Error_Msg_Name_1 := Token_Name;
Error_Msg_Warn := Warning;
if Warning then Error_Msg ("<undefined attribute {", Token_Ptr);
Error_Msg ("?undefined attribute {", Token_Ptr);
else
Error_Msg ("undefined attribute {", Token_Ptr);
end if;
end if; end if;
-- Set, if appropriate the index case insensitivity flag -- Set, if appropriate the index case insensitivity flag
......
gcc/ada/prj-nmsc.adb
...@@ -38,7 +38,6 @@ with Prj.Util; use Prj.Util; ...@@ -38,7 +38,6 @@ with Prj.Util; use Prj.Util;
with Sinput.P; with Sinput.P;
with Snames; use Snames; with Snames; use Snames;
with Table; use Table; with Table; use Table;
with Types; use Types;
with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Strings; use Ada.Strings; with Ada.Strings; use Ada.Strings;
...@@ -47,7 +46,6 @@ with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; ...@@ -47,7 +46,6 @@ with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.Case_Util; use GNAT.Case_Util;
with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.HTable; with GNAT.HTable;
package body Prj.Nmsc is package body Prj.Nmsc is
...@@ -876,7 +874,6 @@ package body Prj.Nmsc is ...@@ -876,7 +874,6 @@ package body Prj.Nmsc is
while Source_Id /= No_Other_Source loop while Source_Id /= No_Other_Source loop
Source := In_Tree.Other_Sources.Table (Source_Id); Source := In_Tree.Other_Sources.Table (Source_Id);
Source_Id := Source.Next;
if Source.File_Name = File_Id then if Source.File_Name = File_Id then
...@@ -939,6 +936,8 @@ package body Prj.Nmsc is ...@@ -939,6 +936,8 @@ package body Prj.Nmsc is
Real_Location); Real_Location);
return; return;
end if; end if;
Source_Id := Source.Next;
end loop; end loop;
if Current_Verbosity = High then if Current_Verbosity = High then
...@@ -2368,7 +2367,7 @@ package body Prj.Nmsc is ...@@ -2368,7 +2367,7 @@ package body Prj.Nmsc is
end if; end if;
else else
-- Library_Symbol_File is defined. Check that the file exists. -- Library_Symbol_File is defined. Check that the file exists
Data.Symbol_Data.Symbol_File := Lib_Symbol_File.Value; Data.Symbol_Data.Symbol_File := Lib_Symbol_File.Value;
...@@ -2461,34 +2460,29 @@ package body Prj.Nmsc is ...@@ -2461,34 +2460,29 @@ package body Prj.Nmsc is
then then
Error_Msg_Name_1 := Lib_Ref_Symbol_File.Value; Error_Msg_Name_1 := Lib_Ref_Symbol_File.Value;
-- For controlled symbol policy, it is an error -- For controlled symbol policy, it is an error if the
-- if the reference symbol file does not exist. -- reference symbol file does not exist. For other symbol
-- policies, this is just a warning
if Data.Symbol_Data.Symbol_Policy = Controlled then Error_Msg_Warn :=
Error_Msg Data.Symbol_Data.Symbol_Policy /= Controlled;
(Project, In_Tree,
"library reference symbol file { does not exist",
Lib_Ref_Symbol_File.Location);
else Error_Msg
-- For other symbol policies, this is just a warning (Project, In_Tree,
"<library reference symbol file { does not exist",
Error_Msg Lib_Ref_Symbol_File.Location);
(Project, In_Tree,
"?library reference symbol file { does not exist",
Lib_Ref_Symbol_File.Location);
-- In addition, if symbol policy is Compliant, it is -- In addition in the non-controlled case, if symbol policy
-- changed to Autonomous, because there is no reference -- is Compliant, it is changed to Autonomous, because there
-- to check against, and we don't want to fail in this -- is no reference to check against, and we don't want to
-- case. -- fail in this case.
if Data.Symbol_Data.Symbol_Policy /= Controlled then
if Data.Symbol_Data.Symbol_Policy = Compliant then if Data.Symbol_Data.Symbol_Policy = Compliant then
Data.Symbol_Data.Symbol_Policy := Autonomous; Data.Symbol_Data.Symbol_Policy := Autonomous;
end if; end if;
end if; end if;
end if; end if;
end if; end if;
end if; end if;
end if; end if;
...@@ -2588,11 +2582,19 @@ package body Prj.Nmsc is ...@@ -2588,11 +2582,19 @@ package body Prj.Nmsc is
if Msg (First) = '\' then if Msg (First) = '\' then
First := First + 1; First := First + 1;
-- Warniung character is always the first one in this package -- Warniung character is always the first one in this package
-- this is an undoocumented kludge!!!
elsif Msg (First) = '?' then elsif Msg (First) = '?' then
First := First + 1; First := First + 1;
Add ("Warning: "); Add ("Warning: ");
elsif Msg (First) = '<' then
First := First + 1;
if Err_Vars.Error_Msg_Warn then
Add ("Warning: ");
end if;
end if; end if;
for Index in First .. Msg'Last loop for Index in First .. Msg'Last loop
......
gcc/ada/sem_elab.adb
...@@ -296,17 +296,17 @@ package body Sem_Elab is ...@@ -296,17 +296,17 @@ package body Sem_Elab is
-- convention Stubbed. -- 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
function Within (E1, E2 : Entity_Id) return Boolean; function Within (E1, E2 : Entity_Id) return Boolean;
-- Given two scopes E1 and E2, returns True if E1 is equal to E2, or -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or is one
-- is one of its contained scopes, False otherwise. -- of its contained scopes, False otherwise.
function Within_Elaborate_All (E : Entity_Id) return Boolean; function Within_Elaborate_All (E : Entity_Id) return Boolean;
-- Before emitting a warning on a scope E for a missing elaborate_all, -- Before emitting a warning on a scope E for a missing elaborate_all,
-- check whether E may be in the context of a directly visible unit -- check whether E may be in the context of a directly visible unit U to
-- U to which the pragma applies. This prevents spurious warnings when -- which the pragma applies. This prevents spurious warnings when the
-- the called entity is renamed within U. -- called entity is renamed within U.
------------------ ------------------
-- Check_A_Call -- -- Check_A_Call --
...@@ -963,7 +963,7 @@ package body Sem_Elab is ...@@ -963,7 +963,7 @@ package body Sem_Elab is
then then
return; return;
-- Nothing to do if this is a call already rewritten for elab checking. -- Nothing to do if this is a call already rewritten for elab checking
elsif Nkind (Parent (N)) = N_Conditional_Expression then elsif Nkind (Parent (N)) = N_Conditional_Expression then
return; return;
...@@ -1051,35 +1051,29 @@ package body Sem_Elab is ...@@ -1051,35 +1051,29 @@ package body Sem_Elab is
and then In_Preelaborated_Unit and then In_Preelaborated_Unit
and then not In_Inlined_Body and then not In_Inlined_Body
then then
-- This is a warning in -gnatg mode allowing such calls to -- This is a warning in GNAT mode allowing such calls to be
-- be used in the predefined library with appropriate care. -- used in the predefined library with appropriate care.
if GNAT_Mode then
Error_Msg_N
("?non-static call not allowed in preelaborated unit", N);
else
Error_Msg_N
("non-static call not allowed in preelaborated unit", N);
end if;
Error_Msg_Warn := GNAT_Mode;
Error_Msg_N
("<non-static call not allowed in preelaborated unit", N);
return; return;
end if; end if;
-- Second case, we are inside a subprogram or concurrent unit -- Second case, we are inside a subprogram or concurrent unit, which
-- i.e, we are not in elaboration code. -- means we are not in elaboration code.
else else
-- In this case, the issue is whether we are inside the -- In this case, the issue is whether we are inside the
-- declarative part of the unit in which we live, or inside -- declarative part of the unit in which we live, or inside its
-- its statements. In the latter case, there is no issue of -- statements. In the latter case, there is no issue of ABE calls
-- ABE calls at this level (a call from outside to the unit -- at this level (a call from outside to the unit in which we live
-- in which we live might cause an ABE, but that will be -- might cause an ABE, but that will be detected when we analyze
-- detected when we analyze that outer level call, as it -- that outer level call, as it recurses into the called unit).
-- recurses into the called unit).
-- Climb up the tree, doing this test, and also testing -- Climb up the tree, doing this test, and also testing for being
-- for being inside a default expression, which, as -- inside a default expression, which, as discussed above, is not
-- discussed above, is not checked at this stage. -- checked at this stage.
declare declare
P : Node_Id; P : Node_Id;
...@@ -1088,9 +1082,9 @@ package body Sem_Elab is ...@@ -1088,9 +1082,9 @@ package body Sem_Elab is
begin begin
P := N; P := N;
loop loop
-- If we find a parentless subtree, it seems safe to -- If we find a parentless subtree, it seems safe to assume
-- assume that we are not in a declarative part and -- that we are not in a declarative part and that no
-- that no checking is required. -- checking is required.
if No (P) then if No (P) then
return; return;
...@@ -1106,8 +1100,8 @@ package body Sem_Elab is ...@@ -1106,8 +1100,8 @@ package body Sem_Elab is
exit when Nkind (P) = N_Subunit; exit when Nkind (P) = N_Subunit;
-- Filter out case of default expressions, where -- Filter out case of default expressions, where we do not
-- we do not do the check at this stage. -- do the check at this stage.
if Nkind (P) = N_Parameter_Specification if Nkind (P) = N_Parameter_Specification
or else or else
...@@ -1136,11 +1130,11 @@ package body Sem_Elab is ...@@ -1136,11 +1130,11 @@ package body Sem_Elab is
elsif Dynamic_Elaboration_Checks then elsif Dynamic_Elaboration_Checks then
-- This is a rather new check, going into version -- This is a rather new check, going into version
-- 3.14a1 for the first time (V1.80 of this unit), -- 3.14a1 for the first time (V1.80 of this unit), so
-- so we provide a debug flag to enable it. That -- we provide a debug flag to enable it. That way we
-- way we have an easy work around for regressions -- have an easy work around for regressions that are
-- that are caused by this new check. This debug -- caused by this new check. This debug flag can be
-- flag can be removed later. -- removed later.
if Debug_Flag_DD then if Debug_Flag_DD then
return; return;
...@@ -1381,7 +1375,7 @@ package body Sem_Elab is ...@@ -1381,7 +1375,7 @@ package body Sem_Elab is
return; return;
end if; end if;
-- Nothing to do if the instantiation is not in the main unit. -- Nothing to do if the instantiation is not in the main unit
if not In_Extended_Main_Code_Unit (N) then if not In_Extended_Main_Code_Unit (N) then
return; return;
...@@ -1882,7 +1876,7 @@ package body Sem_Elab is ...@@ -1882,7 +1876,7 @@ package body Sem_Elab is
else else
Elmt := First_Elmt (Inter_Procs); Elmt := First_Elmt (Inter_Procs);
-- No need for multiple entries of the same type. -- No need for multiple entries of the same type
while Present (Elmt) loop while Present (Elmt) loop
if Node (Elmt) = Proc then if Node (Elmt) = Proc then
...@@ -1946,7 +1940,7 @@ package body Sem_Elab is ...@@ -1946,7 +1940,7 @@ package body Sem_Elab is
begin begin
Enclosing := Outer_Unit (Current_Scope); Enclosing := Outer_Unit (Current_Scope);
-- Find all tasks declared in the current unit. -- Find all tasks declared in the current unit
if Nkind (N) = N_Package_Body then if Nkind (N) = N_Package_Body then
P := Unit_Declaration_Node (Corresponding_Spec (N)); P := Unit_Declaration_Node (Corresponding_Spec (N));
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment