mirrors/gcc
0
0
Fork 0
mirror of https://gcc.gnu.org/git/gcc.git synced 2024-12-16 07:23:48 +08:00
Code Issues Actions Packages Projects Releases Wiki Activity

debug.adb: Improve -gnatdI to cover all cases of serialization Add documentation of dZ, d.t

Browse Source 
2007-08-14  Robert Dewar  <dewar@adacore.com>

	* debug.adb: Improve -gnatdI to cover all cases of serialization
	Add documentation of dZ, d.t

	* sprint.ads, sprint.adb: Improve -gnatdI to cover all cases of
	serialization.
	(Sprint_Node_Actual): Generate new output associated with implicit
	importation and implicit exportation of object declarations.

From-SVN: r127414
This commit is contained in:
Robert Dewar 2007-08-14 10:38:03 +02:00 committed by Arnaud Charlet
parent 554846f3b7
commit b99282c4c1
3 changed files with 131 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
gcc/ada/debug.adb
View File

@ -71,7 +71,7 @@ package body Debug is
-- dC Output debugging information on check suppression
-- dD Delete elaboration checks in inner level routines
-- dE Apply elaboration checks to predefined units
-- dF Front end data layout enabled.
-- dF Front end data layout enabled
-- dG Generate all warnings including those normally suppressed
-- dH Hold (kill) call to gigi
-- dI Inhibit internal name numbering in gnatG listing
@ -112,7 +112,7 @@ package body Debug is
-- d.q
-- d.r
-- d.s
-- d.t
-- d.t Disable static allocation of library level dispatch tables
-- d.u
-- d.v
-- d.w Do not check for infinite while loops
@ -393,11 +393,11 @@ package body Debug is
-- layout, and may be useful in other debugging situations where
-- you do not want gigi to intefere with the testing.
-- dI Inhibit internal name numbering in gnatDG listing. For internal
-- names of the form <uppercase-letters><digits><suffix>, the output
-- will be modified to <uppercase-letters>...<suffix>. This is used
-- in the fixed bugs run to minimize system and version dependency
-- in filed -gnatDG output.
-- dI Inhibit internal name numbering in gnatDG listing. Any sequence of
-- the form <uppercase-letter><digits><lowercase-letter> appearing in
-- a name is replaced by <uppercase-letter>...<lowercase-letter>. This
-- is used in the fixed bugs run to minimize system and version
-- dependency in filed -gnatD or -gnatG output.
-- dJ Generate debugging trace output for the JGNAT back end. This
-- consists of symbolic Java Byte Code sequences for all generated
@ -470,6 +470,31 @@ package body Debug is
-- had Configurable_Run_Time_Mode set to True. This is useful in
-- testing high integrity mode.
-- dZ Generate listing showing the contents of the dispatch tables. Each
-- line has an internally generated number used for references between
-- tagged types and primitives. For each primitive the output has the
-- following fields:
-- - Letter 'P' or letter 's': The former indicates that this
-- primitive will be located in a primary dispatch table. The
-- latter indicates that it will be located in a secondary
-- dispatch table.
-- - Name of the primitive. In case of predefined Ada primitives
-- the text "(predefined)" is added before the name, and these
-- acronyms are used: SR (Stream_Read), SW (Stream_Write), SI
-- (Stream_Input), SO (Stream_Output), DA (Deep_Adjust), DF
-- (Deep_Finalize). In addition Oeq identifies the equality
-- operator, and "_assign" the assignment.
-- - If the primitive covers interface types, two extra fields
-- referencing other primitives are generated: "Alias" references
-- the primitive of the tagged type that covers an interface
-- primitive, and "AI_Alias" references the covered interface
-- primitive.
-- - The expression "at #xx" indicates the slot of the dispatch
-- table occupied by such primitive in its corresponding primary
-- or secondary dispatch table.
-- - In case of abstract subprograms the text "is abstract" is
-- added at the end of the line.
-- d.f Suppress folding of static expressions. This of course results
-- in seriously non-conforming behavior, but is useful sometimes
-- when tracking down handling of complex expressions.
@ -489,6 +514,12 @@ package body Debug is
-- main source (this corresponds to a previous behavior of -gnatl and
-- is used for running the ACATS tests).
-- d.t The compiler has been modified (a fairly extensive modification)
-- to generate static dispatch tables for library level tagged types.
-- This debug switch disables this modification and reverts to the
-- previous dynamic construction of tables. It is there as a possible
-- work around if we run into trouble with the new implementation.
-- d.w This flag turns off the scanning of while loops to detect possible
-- infinite loops.

131
gcc/ada/sprint.adb
View File

@ -2005,34 +2005,76 @@ package body Sprint is
Set_Debug_Sloc;
if Write_Indent_Identifiers (Node) then
Write_Str_With_Col_Check (" : ");
declare
Def_Id : constant Entity_Id := Defining_Identifier (Node);
if Is_Statically_Allocated (Defining_Identifier (Node)) then
Write_Str_With_Col_Check ("static ");
end if;
begin
Write_Str_With_Col_Check (" : ");
if Aliased_Present (Node) then
Write_Str_With_Col_Check ("aliased ");
end if;
if Is_Statically_Allocated (Def_Id) then
Write_Str_With_Col_Check ("static ");
end if;
if Constant_Present (Node) then
Write_Str_With_Col_Check ("constant ");
end if;
if Aliased_Present (Node) then
Write_Str_With_Col_Check ("aliased ");
end if;
-- Ada 2005 (AI-231)
if Constant_Present (Node) then
Write_Str_With_Col_Check ("constant ");
end if;
if Null_Exclusion_Present (Node) then
Write_Str_With_Col_Check ("not null ");
end if;
-- Ada 2005 (AI-231)
Sprint_Node (Object_Definition (Node));
if Null_Exclusion_Present (Node) then
Write_Str_With_Col_Check ("not null ");
end if;
if Present (Expression (Node)) then
Write_Str (" := ");
Sprint_Node (Expression (Node));
end if;
Sprint_Node (Object_Definition (Node));
Write_Char (';');
if Present (Expression (Node)) then
Write_Str (" := ");
Sprint_Node (Expression (Node));
end if;
Write_Char (';');
-- Handle implicit importation and implicit exportation of
-- object declarations:
-- $pragma import (Convention_Id, Def_Id, "...");
-- $pragma export (Convention_Id, Def_Id, "...");
if Is_Internal (Def_Id)
and then Present (Interface_Name (Def_Id))
then
Write_Indent_Str_Sloc ("$pragma ");
if Is_Imported (Def_Id) then
Write_Str ("import (");
else pragma Assert (Is_Exported (Def_Id));
Write_Str ("export (");
end if;
declare
Prefix : constant String := "Convention_";
S : constant String := Convention (Def_Id)'Img;
begin
Name_Len := S'Last - Prefix'Last;
Name_Buffer (1 .. Name_Len) :=
S (Prefix'Last + 1 .. S'Last);
Set_Casing (All_Lower_Case);
Write_Str (Name_Buffer (1 .. Name_Len));
end;
Write_Str (", ");
Write_Id (Def_Id);
Write_Str (", ");
Write_String_Table_Entry
(Strval (Interface_Name (Def_Id)));
Write_Str (");");
end if;
end;
end if;
when N_Object_Renaming_Declaration =>
@ -2599,7 +2641,7 @@ package body Sprint is
Write_Char (';');
when N_Return_Statement =>
when N_Simple_Return_Statement =>
if Present (Expression (Node)) then
Write_Indent_Str_Sloc ("return ");
Sprint_Node (Expression (Node));
@ -3929,36 +3971,45 @@ package body Sprint is
procedure Write_Name_With_Col_Check (N : Name_Id) is
J : Natural;
K : Natural;
L : Natural;
begin
Get_Name_String (N);
-- Deal with -gnatI which replaces digits in an internal
-- name by three dots (e.g. R7b becomes R...b).
-- Deal with -gnatdI which replaces any sequence Cnnnb where C is an
-- upper case letter, nnn is one or more digits and b is a lower case
-- letter by C...b, so that listings do not depend on serial numbers.
if Debug_Flag_II and then Name_Buffer (1) in 'A' .. 'Z' then
J := 2;
while J < Name_Len loop
exit when Name_Buffer (J) not in 'A' .. 'Z';
J := J + 1;
end loop;
if Debug_Flag_II then
J := 1;
while J < Name_Len - 1 loop
if Name_Buffer (J) in 'A' .. 'Z'
and then Name_Buffer (J + 1) in '0' .. '9'
then
K := J + 1;
while K < Name_Len loop
exit when Name_Buffer (K) not in '0' .. '9';
K := K + 1;
end loop;
if Name_Buffer (J) in '0' .. '9' then
Write_Str_With_Col_Check (Name_Buffer (1 .. J - 1));
Write_Str ("...");
if Name_Buffer (K) in 'a' .. 'z' then
L := Name_Len - K + 1;
while J <= Name_Len loop
if Name_Buffer (J) not in '0' .. '9' then
Write_Str (Name_Buffer (J .. Name_Len));
exit;
Name_Buffer (J + 4 .. J + L + 3) :=
Name_Buffer (K .. Name_Len);
Name_Buffer (J + 1 .. J + 3) := "...";
Name_Len := J + L + 3;
J := J + 5;
else
J := J + 1;
J := K;
end if;
end loop;
return;
end if;
else
J := J + 1;
end if;
end loop;
end if;
-- Fall through for normal case

2
gcc/ada/sprint.ads
View File

@ -59,6 +59,8 @@ package Sprint is
-- Free statement free expr [storage_pool = xxx]
-- Freeze entity with freeze actions freeze entityname [ actions ]
-- Implicit call to run time routine $routine-name
-- Implicit exportation $pragma import (...)
-- Implicit importation $pragma export (...)
-- Interpretation interpretation type [, entity]
-- Intrinsic calls function-name!(arg, arg, arg)
-- Itype declaration [(sub)type declaration without ;]