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

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

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

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

	* erroutc.ads: Remove unneeded fields from Specific_Warning_Entry

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

From-SVN: r134024

4 files changed, 351 insertions, 360 deletions

diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads
index b9b0616..83b5095 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 c8a0e17..604fd54 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;
-
-      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;
 
    --------------------
@@ -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,110 +1241,92 @@ 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
-
-      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;
diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads
index 1f4eebf..edc1140 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 922a16d..d61ebb0 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;
 
    --------------------------