-- 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
-- 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
-- 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
-- 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.
-- 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.
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 =>
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));
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
OSDN Git Service
