Skip to content

R
riscv-gcc-1
Commit 62b80eaf by Ed Schonberg Committed by Arnaud Charlet
Options

sprint.adb (Write_Itype): Preserve Sloc of declaration... 

2006-02-13  Ed Schonberg  <schonberg@adacore.com>
	    Robert Dewar  <dewar@adacore.com>

	* 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
parent b8e51f72
Showing with 99 additions and 4 deletions
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);
......
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 ;]
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment