From 39485a7b0c07e7a670663ee32d9eb1c6f576fc0f Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Tue, 31 Oct 2006 19:11:05 +0100 Subject: [PATCH] sprint.adb (Sprint_Node_Actual, [...]): Do not print null exclusion twice in the case of an access definition... 2006-10-31 Ed Schonberg Robert Dewar Bob Duff * 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 --- gcc/ada/sprint.adb | 422 ++++++++++++++++++++++++++++++++++++++------- 1 file changed, 360 insertions(+), 62 deletions(-) diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 761c7cf04ed..2343aec98cc 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; -- 2.30.2