From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 22234 invoked by alias); 16 Aug 2007 08:24:10 -0000 Received: (qmail 21694 invoked by uid 22791); 16 Aug 2007 08:24:06 -0000 X-Spam-Check-By: sourceware.org Received: from province.act-europe.fr (HELO province.act-europe.fr) (212.157.227.214) by sourceware.org (qpsmtpd/0.31) with ESMTP; Thu, 16 Aug 2007 08:24:02 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-province.act-europe.fr (Postfix) with ESMTP id 74478165B30; Thu, 16 Aug 2007 10:23:59 +0200 (CEST) Received: from province.act-europe.fr ([127.0.0.1]) by localhost (province.act-europe.fr [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id nlCKaS6l9N4K; Thu, 16 Aug 2007 10:23:59 +0200 (CEST) Received: from cardhu.act-europe.fr (cardhu.act-europe.fr [10.10.0.168]) by province.act-europe.fr (Postfix) with ESMTP id 2380816596C; Thu, 16 Aug 2007 10:23:59 +0200 (CEST) Received: by cardhu.act-europe.fr (Postfix, from userid 525) id 153EC1BF; Thu, 16 Aug 2007 10:23:59 +0200 (CEST) Date: Thu, 16 Aug 2007 08:24:00 -0000 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Robert Dewar Subject: [Ada] improve -gnatdI Message-ID: <20070816082359.GA31311@adacore.com> Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="mP3DRpeJDSE+ciuQ" Content-Disposition: inline User-Agent: Mutt/1.4.1i X-IsSubscribed: yes Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org X-SW-Source: 2007-08/txt/msg00989.txt.bz2 --mP3DRpeJDSE+ciuQ Content-Type: text/plain; charset=us-ascii Content-Disposition: inline Content-length: 1145 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 * 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. --mP3DRpeJDSE+ciuQ Content-Type: text/plain; charset=us-ascii Content-Disposition: attachment; filename=difs Content-length: 11732 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 , 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. 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 --mP3DRpeJDSE+ciuQ--