From 8b3e2261fa09a20e38085f215912bb8abea3af3f Mon Sep 17 00:00:00 2001 From: charlet Date: Tue, 14 Aug 2007 08:38:03 +0000 Subject: [PATCH] 2007-08-14 Robert Dewar * 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@127414 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/debug.adb | 45 +++++++++++++++--- gcc/ada/sprint.adb | 131 +++++++++++++++++++++++++++++++++++++---------------- gcc/ada/sprint.ads | 2 + 3 files changed, 131 insertions(+), 47 deletions(-) diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 1ddd1f6..8b3ff39 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -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 , the output - -- will be modified to .... 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 appearing in + -- a name is replaced by .... 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. diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 23b284b..4c328b1 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -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 diff --git a/gcc/ada/sprint.ads b/gcc/ada/sprint.ads index 2fc17e2..e5d0d3c 100644 --- a/gcc/ada/sprint.ads +++ b/gcc/ada/sprint.ads @@ -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 ;] -- 2.7.4