sprint.adb (Sprint_Node_Actual, [...]): Do not print null exclusion twice in the case of an access definition...

2006-10-31  Ed Schonberg  <schonberg@adacore.com>
	    Robert Dewar  <dewar@adacore.com>
	    Bob Duff  <duff@adacore.com>

	* sprint.adb (Sprint_Node_Actual, case Parameter_Specification): Do not
	print null exclusion twice in the case of an access definition,
	Implement new -gnatL switch
	Remove N_Return_Object_Declaration. We now use
	N_Object_Declaration instead. Implement the case for
	N_Extended_Return_Statement. Alphabetize the cases.
	Add cases for new nodes N_Extended_Return_Statement and
	N_Return_Object_Declaration. The code is not yet written.
	Update the output for N_Formal_Object_Declaration
	and N_Object_Renaming_Declaration.
	(Write_Itype): Account for the case of a modular integer subtype whose
	base type is private.

From-SVN: r118314

1 files changed, 360 insertions, 62 deletions

diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb
index 761c7cf..2343aec 100644
--- a/gcc/ada/sprint.adb
+++ b/gcc/ada/sprint.adb
@@ -47,11 +47,14 @@ with Uname;    use Uname;
 with Urealp;   use Urealp;
 
 package body Sprint is
+   Current_Source_File : Source_File_Index;
+   --  Index of source file whose generated code is being dumped
 
-   Debug_Node : Node_Id := Empty;
-   --  If we are in Debug_Generated_Code mode, then this location is set
-   --  to the current node requiring Sloc fixup, until Set_Debug_Sloc is
-   --  called to set the proper value. The call clears it back to Empty.
+   Dump_Node : Node_Id := Empty;
+   --  This is set to the current node, used for printing line numbers. In
+   --  Debug_Generated_Code mode, Dump_Node is set to the current node
+   --  requiring Sloc fixup, until Set_Debug_Sloc is called to set the proper
+   --  value. The call clears it back to Empty.
 
    Debug_Sloc : Source_Ptr;
    --  Sloc of first byte of line currently being written if we are
@@ -67,6 +70,12 @@ package body Sprint is
    Dump_Freeze_Null : Boolean;
    --  Set True if freeze nodes and non-source null statements output
 
+   Freeze_Indent : Int := 0;
+   --  Keep track of freeze indent level (controls output of blank lines before
+   --  procedures within expression freeze actions). Relevant only if we are
+   --  not in Dump_Source_Text mode, since in Dump_Source_Text mode we don't
+   --  output these blank lines in any case.
+
    Indent : Int := 0;
    --  Number of columns for current line output indentation
 
@@ -74,13 +83,13 @@ package body Sprint is
    --  Set True if subsequent Write_Indent call to be ignored, gets reset
    --  by this call, so it is only active to suppress a single indent call.
 
+   Last_Line_Printed : Physical_Line_Number;
+   --  This keeps track of the physical line number of the last source line
+   --  that has been output. The value is only valid in Dump_Source_Text mode.
+
    Line_Limit : constant := 72;
    --  Limit value for chopping long lines
 
-   Freeze_Indent : Int := 0;
-   --  Keep track of freeze indent level (controls blank lines before
-   --  procedures within expression freeze actions)
-
    -------------------------------
    -- Operator Precedence Table --
    -------------------------------
@@ -139,6 +148,13 @@ package body Sprint is
    --  then start an extra line with two characters extra indentation for
    --  continuing text on the next line.
 
+   procedure Extra_Blank_Line;
+   --  In some situations we write extra blank lines to separate the generated
+   --  code to make it more readable. However, these extra blank lines are not
+   --  generated in Dump_Source_Text mode, since there the source text lines
+   --  output with preceding blank lines are quite sufficient as separators.
+   --  This procedure writes a blank line if Dump_Source_Text is False.
+
    procedure Indent_Annull;
    --  Causes following call to Write_Indent to be ignored. This is used when
    --  a higher level node wants to stop a lower level node from starting a
@@ -166,10 +182,9 @@ package body Sprint is
    --  appropriate special syntax characters (# and @).
 
    procedure Set_Debug_Sloc;
-   --  If Debug_Node is non-empty, this routine sets the appropriate value
+   --  If Dump_Node is non-empty, this routine sets the appropriate value
    --  in its Sloc field, from the current location in the debug source file
-   --  that is currently being written. Note that Debug_Node is always empty
-   --  if a debug source file is not being written.
+   --  that is currently being written.
 
    procedure Sprint_And_List (List : List_Id);
    --  Print the given list with items separated by vertical "and"
@@ -194,6 +209,11 @@ package body Sprint is
    procedure Write_Condition_And_Reason (Node : Node_Id);
    --  Write Condition and Reason codes of Raise_xxx_Error node
 
+   procedure Write_Corresponding_Source (S : String);
+   --  If S is a string with a single keyword (possibly followed by a space),
+   --  and if the next non-comment non-blank source line matches this keyword,
+   --  then output all source lines up to this matching line.
+
    procedure Write_Discr_Specs (N : Node_Id);
    --  Ouput discriminant specification for node, which is any of the type
    --  declarations that can have discriminants.
@@ -271,6 +291,19 @@ package body Sprint is
    --  generated code only, since in this case we don't specially mark nodes
    --  created by rewriting).
 
+   procedure Write_Source_Line (L : Physical_Line_Number);
+   --  If writing of interspersed source lines is enabled, then write the given
+   --  line from the source file, preceded by Eol, then an extra blank line if
+   --  the line has at least one blank, is not a comment and is not line one,
+   --  then "--" and the line number followed by period followed by text of the
+   --  source line (without terminating Eol). If interspersed source line
+   --  output not enabled, then the call has no effect.
+
+   procedure Write_Source_Lines (L : Physical_Line_Number);
+   --  If writing of interspersed source lines is enabled, then writes source
+   --  lines Last_Line_Printed + 1 .. L, and updates Last_Line_Printed. If
+   --  interspersed source line output not enabled, then call has no effect.
+
    procedure Write_Str_Sloc (S : String);
    --  Like Write_Str, but sets debug Sloc of current debug node to first
    --  non-blank character if a current debug node is active.
@@ -312,6 +345,17 @@ package body Sprint is
       end if;
    end Col_Check;
 
+   ----------------------
+   -- Extra_Blank_Line --
+   ----------------------
+
+   procedure Extra_Blank_Line is
+   begin
+      if not Dump_Source_Text then
+         Write_Indent;
+      end if;
+   end Extra_Blank_Line;
+
    -------------------
    -- Indent_Annull --
    -------------------
@@ -371,6 +415,7 @@ package body Sprint is
    begin
       Dump_Generated_Only := True;
       Dump_Original_Only := False;
+      Current_Source_File := No_Source_File;
       Sprint_Node (Node);
       Write_Eol;
    end pg;
@@ -383,6 +428,7 @@ package body Sprint is
    begin
       Dump_Generated_Only := False;
       Dump_Original_Only := True;
+      Current_Source_File := No_Source_File;
       Sprint_Node (Node);
       Write_Eol;
    end po;
@@ -419,6 +465,7 @@ package body Sprint is
    begin
       Dump_Generated_Only := False;
       Dump_Original_Only := False;
+      Current_Source_File := No_Source_File;
       Sprint_Node (Node);
       Write_Eol;
    end ps;
@@ -429,9 +476,9 @@ package body Sprint is
 
    procedure Set_Debug_Sloc is
    begin
-      if Present (Debug_Node) then
-         Set_Sloc (Debug_Node, Debug_Sloc + Source_Ptr (Column - 1));
-         Debug_Node := Empty;
+      if Debug_Generated_Code and then Present (Dump_Node) then
+         Set_Sloc (Dump_Node, Debug_Sloc + Source_Ptr (Column - 1));
+         Dump_Node := Empty;
       end if;
    end Set_Debug_Sloc;
 
@@ -444,6 +491,10 @@ package body Sprint is
       procedure Underline;
       --  Put underline under string we just printed
 
+      ---------------
+      -- Underline --
+      ---------------
+
       procedure Underline is
          Col : constant Int := Column;
 
@@ -472,6 +523,7 @@ package body Sprint is
       --  avoids an infinite loop if an abort occurs during the dump.
 
       if Debug_Flag_Z then
+         Current_Source_File := No_Source_File;
          Debug_Flag_Z := False;
          Write_Eol;
          Write_Eol;
@@ -490,6 +542,7 @@ package body Sprint is
          --  Dump requested units
 
          for U in Main_Unit .. Last_Unit loop
+            Current_Source_File := Source_Index (U);
 
             --  Dump all units if -gnatdf set, otherwise we dump only
             --  the source files that are in the extended main source.
@@ -502,7 +555,10 @@ package body Sprint is
                if Debug_Generated_Code then
                   Set_Special_Output (Print_Debug_Line'Access);
                   Create_Debug_Source (Source_Index (U), Debug_Sloc);
+                  Write_Source_Line (1);
+                  Last_Line_Printed := 1;
                   Sprint_Node (Cunit (U));
+                  Write_Source_Lines (Last_Source_Line (Current_Source_File));
                   Write_Eol;
                   Close_Debug_Source;
                   Set_Special_Output (null);
@@ -513,7 +569,10 @@ package body Sprint is
                   Write_Str ("Source recreated from tree for ");
                   Write_Unit_Name (Unit_Name (U));
                   Underline;
+                  Write_Source_Line (1);
+                  Last_Line_Printed := 1;
                   Sprint_Node (Cunit (U));
+                  Write_Source_Lines (Last_Source_Line (Current_Source_File));
                   Write_Eol;
                   Write_Eol;
                end if;
@@ -670,7 +729,7 @@ package body Sprint is
    ------------------------
 
    procedure Sprint_Node_Actual (Node : Node_Id) is
-      Save_Debug_Node : constant Node_Id := Debug_Node;
+      Save_Dump_Node : constant Node_Id := Dump_Node;
 
    begin
       if Node = Empty then
@@ -681,12 +740,9 @@ package body Sprint is
          Write_Str_With_Col_Check ("(");
       end loop;
 
-      --  Setup node for Sloc fixup if writing a debug source file. Note
-      --  that we take care of any previous node not yet properly set.
+      --  Setup current dump node
 
-      if Debug_Generated_Code then
-         Debug_Node := Node;
-      end if;
+      Dump_Node := Node;
 
       if Nkind (Node) in N_Subexpr
         and then Do_Range_Check (Node)
@@ -1388,6 +1444,18 @@ package body Sprint is
             Write_Char_Sloc ('.');
             Write_Str_Sloc ("all");
 
+         when N_Extended_Return_Statement =>
+            Write_Indent_Str_Sloc ("return ");
+            Sprint_Node_List (Return_Object_Declarations (Node));
+
+            if Present (Handled_Statement_Sequence (Node)) then
+               Write_Str_With_Col_Check (" do");
+               Sprint_Node (Handled_Statement_Sequence (Node));
+               Write_Indent_Str ("end return;");
+            else
+               Write_Indent_Str (";");
+            end if;
+
          when N_Extension_Aggregate =>
             Write_Str_With_Col_Check_Sloc ("(");
             Sprint_Node (Ancestor_Part (Node));
@@ -1478,11 +1546,27 @@ package body Sprint is
                   Write_Str_With_Col_Check ("out ");
                end if;
 
-               Sprint_Node (Subtype_Mark (Node));
+               if Present (Subtype_Mark (Node)) then
 
-               if Present (Expression (Node)) then
+                  --  Ada 2005 (AI-423): Formal object with null exclusion
+
+                  if Null_Exclusion_Present (Node) then
+                     Write_Str ("not null ");
+                  end if;
+
+                  Sprint_Node (Subtype_Mark (Node));
+
+               --  Ada 2005 (AI-423): Formal object with access definition
+
+               else
+                  pragma Assert (Present (Access_Definition (Node)));
+
+                  Sprint_Node (Access_Definition (Node));
+               end if;
+
+               if Present (Default_Expression (Node)) then
                   Write_Str (" := ");
-                  Sprint_Node (Expression (Node));
+                  Sprint_Node (Default_Expression (Node));
                end if;
 
                Write_Char (';');
@@ -1550,6 +1634,10 @@ package body Sprint is
                   Write_Char (']');
 
                else
+                  --  Output freeze actions. We increment Freeze_Indent during
+                  --  this output to avoid generating extra blank lines before
+                  --  any procedures included in the freeze actions.
+
                   Freeze_Indent := Freeze_Indent + 1;
                   Sprint_Indented_List (Actions (Node));
                   Freeze_Indent := Freeze_Indent - 1;
@@ -1615,7 +1703,7 @@ package body Sprint is
             Write_Char (';');
 
          when N_Generic_Package_Declaration =>
-            Write_Indent;
+            Extra_Blank_Line;
             Write_Indent_Str_Sloc ("generic ");
             Sprint_Indented_List (Generic_Formal_Declarations (Node));
             Write_Indent;
@@ -1637,7 +1725,7 @@ package body Sprint is
             Write_Char (';');
 
          when N_Generic_Subprogram_Declaration =>
-            Write_Indent;
+            Extra_Blank_Line;
             Write_Indent_Str_Sloc ("generic ");
             Sprint_Indented_List (Generic_Formal_Declarations (Node));
             Write_Indent;
@@ -1870,6 +1958,13 @@ package body Sprint is
                Sprint_Node (Access_Definition (Node));
 
             elsif Present (Subtype_Mark (Node)) then
+
+               --  Ada 2005 (AI-423): Object renaming with a null exclusion
+
+               if Null_Exclusion_Present (Node) then
+                  Write_Str ("not null ");
+               end if;
+
                Sprint_Node (Subtype_Mark (Node));
 
             else
@@ -2026,7 +2121,7 @@ package body Sprint is
             Write_Str_With_Col_Check_Sloc ("others");
 
          when N_Package_Body =>
-            Write_Indent;
+            Extra_Blank_Line;
             Write_Indent_Str_Sloc ("package body ");
             Sprint_Node (Defining_Unit_Name (Node));
             Write_Str (" is");
@@ -2047,13 +2142,13 @@ package body Sprint is
             Write_Str_With_Col_Check (" is separate;");
 
          when N_Package_Declaration =>
-            Write_Indent;
+            Extra_Blank_Line;
             Write_Indent;
             Sprint_Node_Sloc (Specification (Node));
             Write_Char (';');
 
          when N_Package_Instantiation =>
-            Write_Indent;
+            Extra_Blank_Line;
             Write_Indent_Str_Sloc ("package ");
             Sprint_Node (Defining_Unit_Name (Node));
             Write_Str (" is new ");
@@ -2101,9 +2196,15 @@ package body Sprint is
                   Write_Str_With_Col_Check ("out ");
                end if;
 
-               --  Ada 2005 (AI-231)
+               --  Ada 2005 (AI-231) parameter specification may carry
+               --  null exclusion. Do not print it now if this is an
+               --  access parameter, it is emitted when the access
+               --  definition is displayed.
 
-               if Null_Exclusion_Present (Node) then
+               if Null_Exclusion_Present (Node)
+                 and then Nkind (Parameter_Type (Node))
+                   /= N_Access_Definition
+               then
                   Write_Str ("not null ");
                end if;
 
@@ -2451,8 +2552,11 @@ package body Sprint is
             Write_String_Table_Entry (Strval (Node));
 
          when N_Subprogram_Body =>
+
+            --  Output extra blank line unless we are in freeze actions
+
             if Freeze_Indent = 0 then
-               Write_Indent;
+               Extra_Blank_Line;
             end if;
 
             Write_Indent;
@@ -2525,7 +2629,7 @@ package body Sprint is
             Write_Indent_Str_Sloc ("separate (");
             Sprint_Node (Name (Node));
             Write_Char (')');
-            Write_Eol;
+            Extra_Blank_Line;
             Sprint_Node (Proper_Body (Node));
 
          when N_Task_Body =>
@@ -2761,8 +2865,7 @@ package body Sprint is
          Write_Char (')');
       end loop;
 
-      pragma Assert (No (Debug_Node));
-      Debug_Node := Save_Debug_Node;
+      Dump_Node := Save_Dump_Node;
    end Sprint_Node_Actual;
 
    ----------------------
@@ -2792,9 +2895,9 @@ package body Sprint is
    begin
       Sprint_Node (Node);
 
-      if Present (Debug_Node) then
-         Set_Sloc (Debug_Node, Sloc (Node));
-         Debug_Node := Empty;
+      if Debug_Generated_Code and then Present (Dump_Node) then
+         Set_Sloc (Dump_Node, Sloc (Node));
+         Dump_Node := Empty;
       end if;
    end Sprint_Node_Sloc;
 
@@ -2905,17 +3008,45 @@ package body Sprint is
    --------------------------------
 
    procedure Write_Condition_And_Reason (Node : Node_Id) is
-      Image : constant String := RT_Exception_Code'Image
-                                   (RT_Exception_Code'Val
-                                     (UI_To_Int (Reason (Node))));
+      Cond  : constant Node_Id := Condition (Node);
+      Image : constant String  := RT_Exception_Code'Image
+                                    (RT_Exception_Code'Val
+                                       (UI_To_Int (Reason (Node))));
 
    begin
-      if Present (Condition (Node)) then
-         Write_Str_With_Col_Check (" when ");
-         Sprint_Node (Condition (Node));
+      if Present (Cond) then
+
+         --  If condition is a single entity, or NOT with a single entity,
+         --  output all on one line, since it will likely fit just fine.
+
+         if Is_Entity_Name (Cond)
+           or else (Nkind (Cond) = N_Op_Not
+                     and then Is_Entity_Name (Right_Opnd (Cond)))
+         then
+            Write_Str_With_Col_Check (" when ");
+            Sprint_Node (Cond);
+            Write_Char (' ');
+
+            --  Otherwise for more complex condition, multiple lines
+
+         else
+            Write_Str_With_Col_Check (" when");
+            Indent := Indent + 2;
+            Write_Indent;
+            Sprint_Node (Cond);
+            Write_Indent;
+            Indent := Indent - 2;
+         end if;
+
+      --  If no condition, just need a space (all on one line)
+
+      else
+         Write_Char (' ');
       end if;
 
-      Write_Str (" """);
+      --  Write the reason
+
+      Write_Char ('"');
 
       for J in 4 .. Image'Last loop
          if Image (J) = '_' then
@@ -2928,6 +3059,93 @@ package body Sprint is
       Write_Str ("""]");
    end Write_Condition_And_Reason;
 
+   --------------------------------
+   -- Write_Corresponding_Source --
+   --------------------------------
+
+   procedure Write_Corresponding_Source (S : String) is
+      Loc : Source_Ptr;
+      Src : Source_Buffer_Ptr;
+
+   begin
+      --  Ignore if not in dump source text mode, or if in freeze actions
+
+      if Dump_Source_Text and then Freeze_Indent = 0 then
+
+         --  Ignore null string
+
+         if S = "" then
+            return;
+         end if;
+
+         --  Ignore space or semicolon at end of given string
+
+         if S (S'Last) = ' ' or else S (S'Last) = ';' then
+            Write_Corresponding_Source (S (S'First .. S'Last - 1));
+            return;
+         end if;
+
+         --  Loop to look at next lines not yet printed in source file
+
+         for L in
+           Last_Line_Printed + 1 .. Last_Source_Line (Current_Source_File)
+         loop
+            Src := Source_Text (Current_Source_File);
+            Loc := Line_Start (L, Current_Source_File);
+
+            --  If comment, keep looking
+
+            if Src (Loc .. Loc + 1) = "--" then
+               null;
+
+            --  Search to first non-blank
+
+            else
+               while Src (Loc) not in Line_Terminator loop
+
+                  --  Non-blank found
+
+                  if Src (Loc) /= ' ' and then Src (Loc) /= ASCII.HT then
+
+                     --  Loop through characters in string to see if we match
+
+                     for J in S'Range loop
+
+                        --  If mismatch, then not the case we are looking for
+
+                        if Src (Loc) /= S (J) then
+                           return;
+                        end if;
+
+                        Loc := Loc + 1;
+                     end loop;
+
+                     --  If we fall through, string matched, if white space or
+                     --  semicolon after the matched string, this is the case
+                     --  we are looking for.
+
+                     if Src (Loc) in Line_Terminator
+                       or else Src (Loc) = ' '
+                       or else Src (Loc) = ASCII.HT
+                       or else Src (Loc) = ';'
+                     then
+                        --  So output source lines up to and including this one
+
+                        Write_Source_Lines (L);
+                        return;
+                     end if;
+                  end if;
+
+                  Loc := Loc + 1;
+               end loop;
+            end if;
+
+         --  Line was all blanks, or a comment line, keep looking
+
+         end loop;
+      end if;
+   end Write_Corresponding_Source;
+
    -----------------------
    -- Write_Discr_Specs --
    -----------------------
@@ -3107,10 +3325,19 @@ package body Sprint is
    ------------------
 
    procedure Write_Indent is
+      Loc : constant Source_Ptr := Sloc (Dump_Node);
+
    begin
       if Indent_Annull_Flag then
          Indent_Annull_Flag := False;
       else
+         if Dump_Source_Text and then Loc > No_Location then
+            if Get_Source_File_Index (Loc) = Current_Source_File then
+               Write_Source_Lines
+                 (Get_Physical_Line_Number (Sloc (Dump_Node)));
+            end if;
+         end if;
+
          Write_Eol;
 
          for J in 1 .. Indent loop
@@ -3177,9 +3404,7 @@ package body Sprint is
       --  The remainder of the declaration must be printed unless we are
       --  printing the original tree and this is not the last identifier
 
-      return
-         not Dump_Original_Only or else not More_Ids (Node);
-
+      return not Dump_Original_Only or else not More_Ids (Node);
    end Write_Indent_Identifiers_Sloc;
 
    ----------------------
@@ -3188,6 +3413,7 @@ package body Sprint is
 
    procedure Write_Indent_Str (S : String) is
    begin
+      Write_Corresponding_Source (S);
       Write_Indent;
       Write_Str (S);
    end Write_Indent_Str;
@@ -3198,6 +3424,7 @@ package body Sprint is
 
    procedure Write_Indent_Str_Sloc (S : String) is
    begin
+      Write_Corresponding_Source (S);
       Write_Indent;
       Write_Str_Sloc (S);
    end Write_Indent_Str_Sloc;
@@ -3352,21 +3579,37 @@ package body Sprint is
 
                      Write_Id (B);
 
-                     --  Print bounds if not different from base type
+                     --  Print bounds if different from base type
 
                      declare
                         L  : constant Node_Id := Type_Low_Bound (Typ);
                         H  : constant Node_Id := Type_High_Bound (Typ);
-                        LE : constant Node_Id := Type_Low_Bound (B);
-                        HE : constant Node_Id := Type_High_Bound (B);
+                        LE : Node_Id;
+                        HE : Node_Id;
 
                      begin
-                        if Nkind (L) = N_Integer_Literal
-                          and then Nkind (H) = N_Integer_Literal
-                          and then Nkind (LE) = N_Integer_Literal
-                          and then Nkind (HE) = N_Integer_Literal
-                          and then UI_Eq (Intval (L), Intval (LE))
-                          and then UI_Eq (Intval (H), Intval (HE))
+                        --  B can either be a scalar type, in which case the
+                        --  declaration of Typ may constrain it with different
+                        --  bounds, or a private type, in which case we know
+                        --  that the declaration of Typ cannot have a scalar
+                        --  constraint.
+
+                        if Is_Scalar_Type (B) then
+                           LE := Type_Low_Bound (B);
+                           HE := Type_High_Bound (B);
+                        else
+                           LE := Empty;
+                           HE := Empty;
+                        end if;
+
+                        if No (LE)
+                          or else (True
+                            and then Nkind (L) = N_Integer_Literal
+                            and then Nkind (H) = N_Integer_Literal
+                            and then Nkind (LE) = N_Integer_Literal
+                            and then Nkind (HE) = N_Integer_Literal
+                            and then UI_Eq (Intval (L), Intval (LE))
+                            and then UI_Eq (Intval (H), Intval (HE)))
                         then
                            null;
 
@@ -3659,9 +3902,9 @@ package body Sprint is
       end if;
    end Write_Param_Specs;
 
-   --------------------------
+   -----------------------
    -- Write_Rewrite_Str --
-   --------------------------
+   -----------------------
 
    procedure Write_Rewrite_Str (S : String) is
    begin
@@ -3674,6 +3917,61 @@ package body Sprint is
       end if;
    end Write_Rewrite_Str;
 
+   -----------------------
+   -- Write_Source_Line --
+   -----------------------
+
+   procedure Write_Source_Line (L : Physical_Line_Number) is
+      Loc : Source_Ptr;
+      Src : Source_Buffer_Ptr;
+      Scn : Source_Ptr;
+
+   begin
+      if Dump_Source_Text then
+         Src := Source_Text (Current_Source_File);
+         Loc := Line_Start (L, Current_Source_File);
+         Write_Eol;
+
+         --  See if line is a comment line, if not, and if not line one,
+         --  precede with blank line.
+
+         Scn := Loc;
+         while Src (Scn) = ' ' or else Src (Scn) = ASCII.HT loop
+            Scn := Scn + 1;
+         end loop;
+
+         if (Src (Scn) in Line_Terminator
+              or else Src (Scn .. Scn + 1) /= "--")
+           and then L /= 1
+         then
+            Write_Eol;
+         end if;
+
+         --  Now write the source text of the line
+
+         Write_Str ("-- ");
+         Write_Int (Int (L));
+         Write_Str (": ");
+
+         while Src (Loc) not in Line_Terminator loop
+            Write_Char (Src (Loc));
+            Loc := Loc + 1;
+         end loop;
+      end if;
+   end Write_Source_Line;
+
+   ------------------------
+   -- Write_Source_Lines --
+   ------------------------
+
+   procedure Write_Source_Lines (L : Physical_Line_Number) is
+   begin
+      while Last_Line_Printed < L loop
+         Last_Line_Printed := Last_Line_Printed + 1;
+         Write_Source_Line (Last_Line_Printed);
+      end loop;
+   end Write_Source_Lines;
+
    --------------------
    -- Write_Str_Sloc --
    --------------------
@@ -3694,8 +3992,8 @@ package body Sprint is
       if Int (S'Last) + Column > Line_Limit then
          Write_Indent_Str ("  ");
 
-         if S (1) = ' ' then
-            Write_Str (S (2 .. S'Length));
+         if S (S'First) = ' ' then
+            Write_Str (S (S'First + 1 .. S'Last));
          else
             Write_Str (S);
          end if;
@@ -3714,8 +4012,8 @@ package body Sprint is
       if Int (S'Last) + Column > Line_Limit then
          Write_Indent_Str ("  ");
 
-         if S (1) = ' ' then
-            Write_Str_Sloc (S (2 .. S'Length));
+         if S (S'First) = ' ' then
+            Write_Str_Sloc (S (S'First + 1 .. S'Last));
          else
             Write_Str_Sloc (S);
          end if;