From: Ed Schonberg Date: Wed, 15 Feb 2006 09:46:08 +0000 (+0100) Subject: sprint.adb (Write_Itype): Preserve Sloc of declaration... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=62b80eaf3872270d72c8ec9a5b57ae04bab76061;p=gcc.git sprint.adb (Write_Itype): Preserve Sloc of declaration... 2006-02-13 Ed Schonberg Robert Dewar * sprint.adb (Write_Itype): Preserve Sloc of declaration, if any, to preserve the source unit where the itype is declared, and prevent a backend abort. (Note_Implicit_Run_Time_Call): New procedure (Write_Itype): Handle missing cases (E_Class_Wide_Type and E_Subprogram_Type) * sprint.ads: Document use of $ for implicit run time routine call From-SVN: r111099 --- diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 08e6cf892a6..761c7cf04ed 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, 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- -- @@ -29,6 +29,7 @@ with Casing; use Casing; with Csets; use Csets; with Debug; use Debug; with Einfo; use Einfo; +with Fname; use Fname; with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; @@ -150,6 +151,11 @@ package body Sprint is procedure Indent_End; -- Decrease indentation level + procedure Note_Implicit_Run_Time_Call (N : Node_Id); + -- N is the Name field of a function call or procedure statement call. + -- The effect of the call is to output a $ if the call is identified as + -- an implicit call to a run time routine. + procedure Print_Debug_Line (S : String); -- Used to print output lines in Debug_Generated_Code mode (this is used -- as the argument for a call to Set_Special_Output in package Output). @@ -333,6 +339,30 @@ package body Sprint is Indent := Indent - 3; end Indent_End; + --------------------------------- + -- Note_Implicit_Run_Time_Call -- + --------------------------------- + + procedure Note_Implicit_Run_Time_Call (N : Node_Id) is + begin + if not Comes_From_Source (N) + and then Is_Entity_Name (N) + then + declare + Ent : constant Entity_Id := Entity (N); + begin + if not In_Extended_Main_Source_Unit (Ent) + and then + Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Ent))) + then + Col_Check (Length_Of_Name (Chars (Ent))); + Write_Char ('$'); + end if; + end; + end if; + end Note_Implicit_Run_Time_Call; + -------- -- pg -- -------- @@ -1003,7 +1033,7 @@ package body Sprint is Sprint_Bar_List (Choices (Node)); Write_Str (" => "); - -- Ada 2005 (AI-287): Print the mbox if present + -- Ada 2005 (AI-287): Print the box if present if Box_Present (Node) then Write_Str_With_Col_Check ("<>"); @@ -1539,6 +1569,7 @@ package body Sprint is when N_Function_Call => Set_Debug_Sloc; + Note_Implicit_Run_Time_Call (Name (Node)); Sprint_Node (Name (Node)); Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node)); @@ -2146,6 +2177,7 @@ package body Sprint is when N_Procedure_Call_Statement => Write_Indent; Set_Debug_Sloc; + Note_Implicit_Run_Time_Call (Name (Node)); Sprint_Node (Name (Node)); Sprint_Opt_Paren_Comma_List (Parameter_Associations (Node)); Write_Char (';'); @@ -3212,6 +3244,10 @@ package body Sprint is S : constant Saved_Output_Buffer := Save_Output_Buffer; -- Save current output buffer + Old_Sloc : Source_Ptr; + -- Save sloc of related node, so it is not modified when + -- printing with -gnatD. + begin -- Write indentation at start of line @@ -3231,9 +3267,16 @@ package body Sprint is -- Write the declaration enclosed in [], avoiding new line -- at start of declaration, and semicolon at end. + -- Note: The itype may be imported from another unit, in which + -- case we do not want to modify the Sloc of the declaration. + -- Otherwise the itype may appear to be in the current unit, + -- and the back-end will reject a reference out of scope. + Write_Char ('['); Indent_Annull_Flag := True; + Old_Sloc := Sloc (P); Sprint_Node (P); + Set_Sloc (P, Old_Sloc); Write_Erase_Char (';'); -- If no constructed declaration, then we have to concoct the @@ -3410,7 +3453,58 @@ package body Sprint is Indent_End; Write_Indent_Str (" end record"); - -- For all other Itypes, print ??? (fill in later) + -- Class-Wide types + + when E_Class_Wide_Type => + Write_Header; + Write_Name_With_Col_Check (Chars (Etype (Typ))); + Write_Str ("'Class"); + + -- Subprogram types + + when E_Subprogram_Type => + Write_Header; + + if Etype (Typ) = Standard_Void_Type then + Write_Str ("procedure"); + else + Write_Str ("function"); + end if; + + if Present (First_Entity (Typ)) then + Write_Str (" ("); + + declare + Param : Entity_Id; + + begin + Param := First_Entity (Typ); + loop + Write_Id (Param); + Write_Str (" : "); + + if Ekind (Param) = E_In_Out_Parameter then + Write_Str ("in out "); + elsif Ekind (Param) = E_Out_Parameter then + Write_Str ("out "); + end if; + + Write_Id (Etype (Param)); + Next_Entity (Param); + exit when No (Param); + Write_Str (", "); + end loop; + + Write_Char (')'); + end; + end if; + + if Etype (Typ) /= Standard_Void_Type then + Write_Str (" return "); + Write_Id (Etype (Typ)); + end if; + + -- For all other Itypes, print ??? (fill in later) when others => Write_Header (True); diff --git a/gcc/ada/sprint.ads b/gcc/ada/sprint.ads index 997e7a4bd22..0e869f05350 100644 --- a/gcc/ada/sprint.ads +++ b/gcc/ada/sprint.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, 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- -- @@ -56,6 +56,7 @@ package Sprint is -- Operator with range check {operator} (e.g. {+}) -- Free statement free expr [storage_pool = xxx] -- Freeze entity with freeze actions freeze entityname [ actions ] + -- Implicit call to run time routine $routine-name -- Interpretation interpretation type [, entity] -- Intrinsic calls function-name!(arg, arg, arg) -- Itype declaration [(sub)type declaration without ;]