diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index b9b0616fe1c..83b50953010 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -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 diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index c8a0e17fde0..604fd5409e3 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -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; <> - 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; diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index 1f4eebf3584..edc1140fbef 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -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 diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 922a16d53ae..d61ebb09a46 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -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; --------------------------