-- --
-- 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- --
if Errors.Table (D).Warn or Errors.Table (D).Style then
Warnings_Detected := Warnings_Detected - 1;
+
else
Total_Errors_Detected := Total_Errors_Detected - 1;
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;
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;
-- 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;
-
- begin
- Ptr := 1;
- loop
- -- Make sure we do not have ludicrously small line
+ 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;
--------------------
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;
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;
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;
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;
(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
-
- Pattern : String_Ptr;
- -- Pattern itself, excluding initial and final *
-
- Star_Start : Boolean;
- Star_End : Boolean;
- -- Indications of * at start and end of original pattern
-
- Msgp : Natural;
- Patp : Natural;
- -- Scan pointers for message and pattern
-
- begin
- -- Loop through specific warning suppression entries
+ -------------
+ -- Matches --
+ -------------
- for J in Specific_Warnings.First .. Specific_Warnings.Last loop
- declare
- SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
+ function Matches (S : String; P : String) return Boolean is
+ Slast : constant Natural := S'Last;
+ PLast : constant Natural := P'Last;
- begin
- -- Pragma applies if it is a configuration pragma, or if the
- -- location is in range of a specific non-configuration pragma.
+ SPtr : Natural := S'First;
+ PPtr : Natural := P'First;
- if SWE.Config
- or else (SWE.Start <= Loc and then Loc <= SWE.Stop)
- then
- -- Check if message matches, dealing with * patterns
+ begin
+ -- Loop advancing through characters of string and pattern
- Patlen := SWE.Patlen;
- Pattern := SWE.Pattern;
- Star_Start := SWE.Star_Start;
- Star_End := SWE.Star_End;
+ SPtr := S'First;
+ PPtr := P'First;
+ loop
+ -- Return True if pattern is a single asterisk
- -- Loop through possible starting positions in Msg
+ if PPtr = PLast and then P (PPtr) = '*' then
+ return True;
- Outer : for M in 1 .. 1 + (Msglen - Patlen) loop
+ -- Return True if both pattern and string exhausted
- -- See if pattern matches string starting at Msg (J)
+ elsif PPtr > PLast and then SPtr > Slast then
+ return True;
- Msgp := M;
- Patp := 1;
- Inner : loop
+ -- Return False, if one exhausted and not the other
- -- 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.
+ elsif PPtr > PLast or else SPtr > Slast then
+ return False;
- if Patp > Patlen then
- if Msgp > Msglen or else Star_End then
- SWE.Used := True;
- return True;
- else
- exit Inner;
- end if;
+ -- Case where pattern starts with asterisk
- -- Otherwise if message exhausted (and we still have
- -- pattern characters left), then match failure here.
+ elsif P (PPtr) = '*' then
- elsif Msgp > Msglen then
- exit Inner;
- end if;
+ -- 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.
- -- Here we have pattern and message characters left
+ for J in SPtr .. Slast loop
+ if Matches (S (J .. Slast), P (PPtr + 1 .. PLast)) then
+ return True;
+ end if;
+ end loop;
- -- Handle "*" pattern match
+ return False;
- if Patp < Patlen - 1 and then
- Pattern (Patp .. Patp + 2) = """*"""
- then
- Patp := Patp + 3;
+ -- Dealt with end of string and *, advance if we have a match
- -- Must have " and at least three chars in msg or we
- -- have no match at this position.
+ elsif S (SPtr) = P (PPtr) then
+ SPtr := SPtr + 1;
+ PPtr := PPtr + 1;
- exit Inner when Msg (Msgp) /= '"';
- Msgp := Msgp + 1;
+ -- If first characters do not match, that's decisive
- -- Scan out " string " in message
+ else
+ return False;
+ end if;
+ end loop;
+ end Matches;
- Scan : loop
- exit Inner when Msgp = Msglen;
- Msgp := Msgp + 1;
- exit Scan when Msg (Msgp - 1) = '"';
- end loop Scan;
+ -- Start of processing for Warning_Specifically_Suppressed
- -- If not "*" case, just compare character
+ begin
+ -- Loop through specific warning suppression entries
- else
- exit Inner when Pattern (Patp) /= Msg (Msgp);
- Patp := Patp + 1;
- Msgp := Msgp + 1;
- end if;
- end loop Inner;
+ for J in Specific_Warnings.First .. Specific_Warnings.Last loop
+ declare
+ SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
- -- Advance to next position if star at end of original
- -- pattern, otherwise no more match attempts are possible
+ begin
+ -- Pragma applies if it is a configuration pragma, or if the
+ -- location is in range of a specific non-configuration pragma.
- exit Outer when not Star_Start;
- end loop Outer;
+ if SWE.Config
+ or else (SWE.Start <= Loc and then Loc <= SWE.Stop)
+ then
+ if Matches (Msg.all, SWE.Msg.all) then
+ SWE.Used := True;
+ return True;
+ end if;
end if;
end;
end loop;
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;
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,
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
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 --
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,
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;
-- 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;
-- 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
-- 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
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
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
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.
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;
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))
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
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;
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;
-- 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???
-- 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)
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.
--------------------
-- 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);
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;
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
-- 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
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
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))
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;
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
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)
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
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);
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;
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
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))
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
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 --
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
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
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;
--------------------------
projects / gcc.git / commitdiff