From: Arnaud Charlet <charlet@adacore.com>
To: gcc-patches@gcc.gnu.org
Cc: Robert Dewar <dewar@adacore.com>
Subject: [Ada] improve -gnatdI
Date: Thu, 16 Aug 2007 08:24:00 -0000 [thread overview]
Message-ID: <20070816082359.GA31311@adacore.com> (raw)
[-- Attachment #1: Type: text/plain, Size: 1145 bytes --]
Tested on i686-linux, committed on trunk
Previously, -gnatdI only removed serialization if a name started with
an upper case letter followed by digits, but now this sequence is
converted (replacing the digits by three dots) anywhere within a name.
Given the test program:
pragma Restrictions (No_Exception_Handlers);
procedure a is
function f return string is
begin
return "abc";
end;
s : string (1 .. 3);
begin
s := f;
end a;
The -gnatG output has lines like:
[subtype a__B3b__S7b is string (R8b .. R9b)]
Before the patch, compiling with -gnatdI gave:
[subtype a__B3b__S7b is string (R...b .. R...b)]
with the patch, we get:
[subtype a__B...b__S...b is string (R...b .. R...b)]
This helps in building base lines for regression tests
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.
[-- Attachment #2: difs --]
[-- Type: text/plain, Size: 11732 bytes --]
Index: debug.adb
===================================================================
--- debug.adb (revision 127358)
+++ debug.adb (working copy)
@@ -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.
Index: sprint.ads
===================================================================
--- sprint.ads (revision 127358)
+++ sprint.ads (working copy)
@@ -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 ;]
Index: sprint.adb
===================================================================
--- sprint.adb (revision 127358)
+++ sprint.adb (working copy)
@@ -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 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 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 Name_Buffer (K) in 'a' .. 'z' then
+ L := Name_Len - K + 1;
- if Name_Buffer (J) in '0' .. '9' then
- Write_Str_With_Col_Check (Name_Buffer (1 .. J - 1));
- Write_Str ("...");
-
- 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
reply other threads:[~2007-08-16 8:24 UTC|newest]
Thread overview: [no followups] expand[flat|nested] mbox.gz Atom feed
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20070816082359.GA31311@adacore.com \
--to=charlet@adacore.com \
--cc=dewar@adacore.com \
--cc=gcc-patches@gcc.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).