Patchwork [Ada] Implement notes lines in ALI file

login
register
mail settings
Submitter Arnaud Charlet
Date June 14, 2010, 1:01 p.m.
Message ID <20100614130151.GA4590@adacore.com>
Download mbox | patch
Permalink /patch/55527/
State New
Headers show

Comments

Arnaud Charlet - June 14, 2010, 1:01 p.m.
This patch generates notes lines in the ALI file for occurrences of
any of the pragmas Annotate/Comment/Ident/Subtitle/Title. These are
used by external tools such as couverture (which uses the Annotate
entries to control temporary disabling of coverage).

The following test program:

package notes is
   pragma Comment ("this is a comment");
   procedure notes1 (N : Integer);
end notes;

package body notes is
   pragma Title (Title => "this is a title");
   procedure notes1 (N : Integer) is
   begin
      pragma Annotate (Coverage, Deactivate, 12, "string", N + 1);
      null;
   end;
end;

generates three N lines in the ali file, one each for the pragmas
Comment, Title, Annotate in the above test program

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-06-14  Robert Dewar  <dewar@adacore.com>

	* ali.adb (Scan_ALI): Implement reading and storing of N lines
	(Known_ALI_Lines): Add entry for 'N' (notes)
	* ali.ads (Notes): New table to store Notes information
	* alloc.ads: Add entries for Notes table
	* lib-util.adb (Write_Info_Int): New procedure
	(Write_Info_Slit): New procedure
	(Write_Info_Uint): New procedure
	* lib-util.ads (Write_Info_Int): New procedure
	(Write_Info_Slit): New procedure
	(Write_Info_Uint): New procedure
	* lib-writ.adb (Write_Unit_Information): Output N (notes) lines
	* lib-writ.ads: Update documentation for N (Notes) lines
	* lib.adb (Store_Note): New procedure
	* lib.ads (Notes): New table
	(Store_Note): New procedure
	* sem_prag.adb: Call Store_Note for affected pragmas

Patch

Index: lib.adb
===================================================================
--- lib.adb	(revision 160705)
+++ lib.adb	(working copy)
@@ -858,6 +858,7 @@  package body Lib is
    procedure Initialize is
    begin
       Linker_Option_Lines.Init;
+      Notes.Init;
       Load_Stack.Init;
       Units.Init;
       Compilation_Switches.Init;
@@ -984,11 +985,18 @@  package body Lib is
 
    procedure Store_Linker_Option_String (S : String_Id) is
    begin
-      Linker_Option_Lines.Increment_Last;
-      Linker_Option_Lines.Table (Linker_Option_Lines.Last) :=
-        (Option => S, Unit => Current_Sem_Unit);
+      Linker_Option_Lines.Append ((Option => S, Unit => Current_Sem_Unit));
    end Store_Linker_Option_String;
 
+   ----------------
+   -- Store_Note --
+   ----------------
+
+   procedure Store_Note (N : Node_Id) is
+   begin
+      Notes.Append ((Pragma_Node => N, Unit => Current_Sem_Unit));
+   end Store_Note;
+
    -------------------------------
    -- Synchronize_Serial_Number --
    -------------------------------
Index: lib.ads
===================================================================
--- lib.ads	(revision 160705)
+++ lib.ads	(working copy)
@@ -574,6 +574,10 @@  package Lib is
    --  This procedure is called to register the string from a pragma
    --  Linker_Option. The argument is the Id of the string to register.
 
+   procedure Store_Note (N : Node_Id);
+   --  This procedure is called to register a pragma N for which a notes
+   --  entry is required.
+
    procedure Initialize;
    --  Initialize internal tables
 
@@ -733,6 +737,21 @@  private
      Table_Increment      => Alloc.Linker_Option_Lines_Increment,
      Table_Name           => "Linker_Option_Lines");
 
+   --  The following table stores references to pragmas that generate Notes
+
+   type Notes_Entry is record
+      Pragma_Node : Node_Id;
+      Unit        : Unit_Number_Type;
+   end record;
+
+   package Notes is new Table.Table (
+     Table_Component_Type => Notes_Entry,
+     Table_Index_Type     => Integer,
+     Table_Low_Bound      => 1,
+     Table_Initial        => Alloc.Notes_Initial,
+     Table_Increment      => Alloc.Notes_Increment,
+     Table_Name           => "Notes");
+
    --  The following table records the compilation switches used to compile
    --  the main unit. The table includes only switches. It excludes -o
    --  switches as well as artifacts of the gcc/gnat1 interface such as
Index: lib-writ.adb
===================================================================
--- lib-writ.adb	(revision 160705)
+++ lib-writ.adb	(working copy)
@@ -592,42 +592,90 @@  package body Lib.Writ is
 
          for J in 1 .. Linker_Option_Lines.Last loop
             declare
-               S : constant Linker_Option_Entry :=
-                     Linker_Option_Lines.Table (J);
-               C : Character;
-
+               S : Linker_Option_Entry renames Linker_Option_Lines.Table (J);
             begin
                if S.Unit = Unit_Num then
                   Write_Info_Initiate ('L');
-                  Write_Info_Str (" """);
+                  Write_Info_Char (' ');
+                  Write_Info_Slit (S.Option);
+                  Write_Info_EOL;
+               end if;
+            end;
+         end loop;
+
+         --  Output notes
+
+         for J in 1 .. Notes.Last loop
+            declare
+               N : constant Node_Id          := Notes.Table (J).Pragma_Node;
+               L : constant Source_Ptr       := Sloc (N);
+               U : constant Unit_Number_Type := Notes.Table (J).Unit;
+               C : Character;
 
-                  for J in 1 .. String_Length (S.Option) loop
-                     C := Get_Character (Get_String_Char (S.Option, J));
+            begin
+               if U = Unit_Num then
+                  Write_Info_Initiate ('N');
+                  Write_Info_Char (' ');
+
+                  case Chars (Pragma_Identifier (N)) is
+                     when Name_Annotate =>
+                        C := 'A';
+                     when Name_Comment =>
+                        C := 'C';
+                     when Name_Ident =>
+                        C := 'I';
+                     when Name_Title =>
+                        C := 'T';
+                     when Name_Subtitle =>
+                        C := 'S';
+                     when others =>
+                        raise Program_Error;
+                  end case;
 
-                     if C in Character'Val (16#20#) .. Character'Val (16#7E#)
-                       and then C /= '{'
-                     then
-                        Write_Info_Char (C);
+                  Write_Info_Char (C);
+                  Write_Info_Int (Int (Get_Logical_Line_Number (L)));
+                  Write_Info_Char (':');
+                  Write_Info_Int (Int (Get_Column_Number (L)));
+
+                  declare
+                     A : Node_Id;
 
-                        if C = '"' then
-                           Write_Info_Char (C);
+                  begin
+                     A := First (Pragma_Argument_Associations (N));
+                     while Present (A) loop
+                        Write_Info_Char (' ');
+
+                        if Chars (A) /= No_Name then
+                           Write_Info_Name (Chars (A));
+                           Write_Info_Char (':');
                         end if;
 
-                     else
                         declare
-                           Hex : constant array (0 .. 15) of Character :=
-                                   "0123456789ABCDEF";
+                           Expr : constant Node_Id := Expression (A);
 
                         begin
-                           Write_Info_Char ('{');
-                           Write_Info_Char (Hex (Character'Pos (C) / 16));
-                           Write_Info_Char (Hex (Character'Pos (C) mod 16));
-                           Write_Info_Char ('}');
+                           if Nkind (Expr) = N_Identifier then
+                              Write_Info_Name (Chars (Expr));
+
+                           elsif Nkind (Expr) = N_Integer_Literal
+                             and then Is_Static_Expression (Expr)
+                           then
+                              Write_Info_Uint (Intval (Expr));
+
+                           elsif Nkind (Expr) = N_String_Literal
+                             and then Is_Static_Expression (Expr)
+                           then
+                              Write_Info_Slit (Strval (Expr));
+
+                           else
+                              Write_Info_Str ("<expr>");
+                           end if;
                         end;
-                     end if;
-                  end loop;
 
-                  Write_Info_Char ('"');
+                        Next (A);
+                     end loop;
+                  end;
+
                   Write_Info_EOL;
                end if;
             end;
Index: lib-writ.ads
===================================================================
--- lib-writ.ads	(revision 160705)
+++ lib-writ.ads	(working copy)
@@ -571,6 +571,40 @@  package Lib.Writ is
    --      source file, so that this order is preserved by the binder in
    --      constructing the set of linker arguments.
 
+   --  --------------
+   --  -- N  Notes --
+   --  --------------
+
+   --  The final section of unit-specific lines contains notes which record
+   --  annotations inserted in source code for processing by external tools
+   --  using pragmas. For each occurrence of any of these pragmas, a line is
+   --  generated with the following syntax:
+
+   --    N x<sloc> [<arg_id>:]<arg> ...
+
+   --      x is one of:
+   --        A  pragma Annotate
+   --        C  pragma Comment
+   --        I  pragma Ident
+   --        T  pragma Title
+   --        S  pragma Subtitle
+
+   --      <sloc> is the source location of the pragma in line:col format
+
+   --      Successive entries record the pragma_argument_associations.
+
+   --        If a pragma argument identifier is present, the entry is prefixed
+   --        with the pragma argument identifier <arg_id> followed by a colon.
+
+   --        <arg> represents the pragma argument, and has the following
+   --        conventions:
+
+   --          - identifiers are output verbatim
+   --          - static string expressions are output as literals encoded as
+   --            for L lines
+   --          - static integer expressions are output as decimal literals
+   --          - any other expression is replaced by the placeholder "<expr>"
+
    ---------------------
    -- Reference Lines --
    ---------------------
@@ -654,40 +688,6 @@  package Lib.Writ is
    --  The cross-reference data follows the dependency lines. See the spec of
    --  Lib.Xref for details on the format of this data.
 
-   --  --------------
-   --  -- N  Notes --
-   --  --------------
-
-   --  The note lines record annotations inserted in source code for processing
-   --  by external tools using pragmas. For each occurrence of any of these
-   --  pragmas, a line is generated with the following syntax:
-
-   --    N <dep>x<sloc> [<arg_id>:]<arg> ...
-
-   --  x is one of:
-   --    A  pragma Annotate
-   --    C  pragma Comment
-   --    I  pragma Ident
-   --    T  pragma Title
-   --    S  pragma Subtitle
-
-   --  <dep>  is the source file containing the pragma by its dependency index
-   --         (first D line has index 1)
-   --  <sloc> is the source location of the pragma
-
-   --  Successive entries record the pragma_argument_associations.
-
-   --  For a named association, the entry is prefixed with the pragma argument
-   --  identifier <arg_id> followed by a colon.
-
-   --  <arg> represents the pragma argument, and has the following conventions:
-
-   --   - identifiers are output verbatim
-   --   - static string expressions are output as literals encoded as for
-   --       L lines
-   --   - static integer expressions are output as decimal literals
-   --   - any other expression is replaced by the placeholder "<expr>"
-
    ---------------------------------
    -- Source Coverage Obligations --
    ---------------------------------
Index: sem_prag.adb
===================================================================
--- sem_prag.adb	(revision 160711)
+++ sem_prag.adb	(working copy)
@@ -376,10 +376,6 @@  package body Sem_Prag is
       --  Any_Integer is OK). If not, given error and raise Pragma_Exit. If
       --  Typ is left Empty, then any static expression is allowed.
 
-      procedure Check_Arg_Is_String_Literal (Arg : Node_Id);
-      --  Check the specified argument Arg to make sure that it is a string
-      --  literal. If not give error and raise Pragma_Exit
-
       procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
       --  Check the specified argument Arg to make sure that it is a valid task
       --  dispatching policy name. If not give error and raise Pragma_Exit.
@@ -1014,19 +1010,6 @@  package body Sem_Prag is
          end if;
       end Check_Arg_Is_Static_Expression;
 
-      ---------------------------------
-      -- Check_Arg_Is_String_Literal --
-      ---------------------------------
-
-      procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is
-         Argx : constant Node_Id := Get_Pragma_Arg (Arg);
-      begin
-         if Nkind (Argx) /= N_String_Literal then
-            Error_Pragma_Arg
-              ("argument for pragma% must be string literal", Argx);
-         end if;
-      end Check_Arg_Is_String_Literal;
-
       ------------------------------------------
       -- Check_Arg_Is_Task_Dispatching_Policy --
       ------------------------------------------
@@ -5244,6 +5227,8 @@  package body Sem_Prag is
             GNAT_Pragma;
             Check_At_Least_N_Arguments (1);
             Check_Arg_Is_Identifier (Arg1);
+            Check_No_Identifiers;
+            Store_Note (N);
 
             declare
                Arg : Node_Id;
@@ -7573,6 +7558,7 @@  package body Sem_Prag is
             Check_Arg_Count (1);
             Check_No_Identifiers;
             Check_Arg_Is_Static_Expression (Arg1, Standard_String);
+            Store_Note (N);
 
             --  For pragma Ident, preserve DEC compatibility by requiring the
             --  pragma to appear in a declarative part or package spec.
@@ -11184,7 +11170,8 @@  package body Sem_Prag is
             GNAT_Pragma;
             Check_Arg_Count (1);
             Check_Optional_Identifier (Arg1, Name_Subtitle);
-            Check_Arg_Is_String_Literal (Arg1);
+            Check_Arg_Is_Static_Expression (Arg1, Standard_String);
+            Store_Note (N);
 
          --------------
          -- Suppress --
@@ -11562,10 +11549,11 @@  package body Sem_Prag is
          begin
             GNAT_Pragma;
             Gather_Associations (Names, Args);
+            Store_Note (N);
 
             for J in 1 .. 2 loop
                if Present (Args (J)) then
-                  Check_Arg_Is_String_Literal (Args (J));
+                  Check_Arg_Is_Static_Expression (Args (J), Standard_String);
                end if;
             end loop;
          end Title;
Index: ali.adb
===================================================================
--- ali.adb	(revision 160728)
+++ ali.adb	(working copy)
@@ -49,6 +49,7 @@  package body ALI is
       'U'    => True,   -- unit
       'W'    => True,   -- with
       'L'    => True,   -- linker option
+      'N'    => True,   -- notes
       'E'    => True,   -- external
       'D'    => True,   -- dependency
       'X'    => True,   -- xref
@@ -89,14 +90,16 @@  package body ALI is
       Withs.Init;
       Sdep.Init;
       Linker_Options.Init;
+      Notes.Init;
       Xref_Section.Init;
       Xref_Entity.Init;
       Xref.Init;
       Version_Ref.Reset;
 
-      --  Add dummy zero'th item in Linker_Options for the sort function
+      --  Add dummy zero'th item in Linker_Options and Notes for sort calls
 
       Linker_Options.Increment_Last;
+      Notes.Increment_Last;
 
       --  Initialize global variables recording cumulative options in all
       --  ALI files that are read for a given processing run in gnatbind.
@@ -1862,6 +1865,45 @@  package body ALI is
             Linker_Options.Table (Linker_Options.Last).Original_Pos :=
               Linker_Options.Last;
          end if;
+
+         --  If there are notes present, scan them
+
+         Notes_Loop : loop
+            Check_Unknown_Line;
+            exit Notes_Loop when C /= 'N';
+
+            if Ignore ('N') then
+               Skip_Line;
+
+            else
+               Checkc (' ');
+
+               Notes.Increment_Last;
+               Notes.Table (Notes.Last).Pragma_Type := Getc;
+               Notes.Table (Notes.Last).Pragma_Line := Get_Nat;
+               Checkc (':');
+               Notes.Table (Notes.Last).Pragma_Col  := Get_Nat;
+               Notes.Table (Notes.Last).Unit        := Units.Last;
+
+               if At_Eol then
+                  Notes.Table (Notes.Last).Pragma_Args := No_Name;
+
+               else
+                  Checkc (' ');
+
+                  Name_Len := 0;
+                  while not At_Eol loop
+                     Add_Char_To_Name_Buffer (Getc);
+                  end loop;
+
+                  Notes.Table (Notes.Last).Pragma_Args := Name_Enter;
+               end if;
+
+               Skip_Eol;
+            end if;
+
+            C := Getc;
+         end loop Notes_Loop;
       end loop U_Loop;
 
       --  End loop through units for one ALI file
Index: ali.ads
===================================================================
--- ali.ads	(revision 160715)
+++ ali.ads	(working copy)
@@ -605,8 +605,6 @@  package ALI is
       --  table.
    end record;
 
-   --  Declare the Linker_Options Table
-
    --  The indexes of active entries in this table range from 1 to the
    --  value of Linker_Options.Last. The zero'th element is for sort call.
 
@@ -618,6 +616,44 @@  package ALI is
      Table_Increment      => 400,
      Table_Name           => "Linker_Options");
 
+   -----------------
+   -- Notes Table --
+   -----------------
+
+   --  The notes table records entries from N lines
+
+   type Notes_Record is record
+      Pragma_Type : Character;
+      --  'A', 'C', 'I', 'S', 'T' for Annotate/Comment/Ident/Subtitle/Title
+
+      Pragma_Line : Nat;
+      --  Line number of pragma
+
+      Pragma_Col : Nat;
+      --  Column number of pragma
+
+      Unit : Unit_Id;
+      --  Unit_Id for the entry
+
+      Pragma_Args : Name_Id;
+      --  Pragma arguments. No_Name if no arguments, otherwise a single
+      --  name table entry consisting of all the characters on the notes
+      --  line from the first non-blank character following the source
+      --  location to the last character on the line.
+   end record;
+
+   --  The indexes of active entries in this table range from 1 to the
+   --  value of Linker_Options.Last. The zero'th element is for convenience
+   --  if the table needs to be sorted.
+
+   package Notes is new Table.Table (
+     Table_Component_Type => Notes_Record,
+     Table_Index_Type     => Integer,
+     Table_Low_Bound      => 0,
+     Table_Initial        => 200,
+     Table_Increment      => 400,
+     Table_Name           => "Notes");
+
    -------------------------------------------
    -- External Version Reference Hash Table --
    -------------------------------------------
Index: alloc.ads
===================================================================
--- alloc.ads	(revision 160705)
+++ alloc.ads	(working copy)
@@ -100,6 +100,9 @@  package Alloc is
    Nodes_Initial                    : constant := 50_000;  -- Atree
    Nodes_Increment                  : constant := 100;
 
+   Notes_Initial                    : constant := 100;     -- Lib
+   Notes_Increment                  : constant := 200;
+
    Obsolescent_Warnings_Initial     : constant := 50;      -- Sem_Prag
    Obsolescent_Warnings_Increment   : constant := 200;
 
Index: lib-util.adb
===================================================================
--- lib-util.adb	(revision 160705)
+++ lib-util.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -25,6 +25,7 @@ 
 
 with Hostparm;
 with Osint.C;  use Osint.C;
+with Stringt;  use Stringt;
 
 package body Lib.Util is
 
@@ -39,7 +40,7 @@  package body Lib.Util is
 
    Info_Buffer_Col : Natural := 1;
    --  Column number of next character to be written.
-   --  Can be different from Info_Buffer_Len + 1
+   --  Can be different from Info_Buffer_Len + 1.
    --  because of tab characters written by Write_Info_Tab.
 
    ---------------------
@@ -133,6 +134,23 @@  package body Lib.Util is
 
    procedure Write_Info_Initiate (Key : Character) renames Write_Info_Char;
 
+   --------------------
+   -- Write_Info_Int --
+   --------------------
+
+   procedure Write_Info_Int (N : Int) is
+   begin
+      if N >= 0 then
+         Write_Info_Nat (N);
+
+      --  Negative numbers, use Write_Info_Uint to avoid problems with largest
+      --  negative number.
+
+      else
+         Write_Info_Uint (UI_From_Int (N));
+      end if;
+   end Write_Info_Int;
+
    ---------------------
    -- Write_Info_Name --
    ---------------------
@@ -169,6 +187,45 @@  package body Lib.Util is
       Write_Info_Char (Character'Val (N mod 10 + Character'Pos ('0')));
    end Write_Info_Nat;
 
+   ---------------------
+   -- Write_Info_Slit --
+   ---------------------
+
+   procedure Write_Info_Slit (S : String_Id) is
+      C : Character;
+
+   begin
+      Write_Info_Str ("""");
+
+      for J in 1 .. String_Length (S) loop
+         C := Get_Character (Get_String_Char (S, J));
+
+         if C in Character'Val (16#20#) .. Character'Val (16#7E#)
+           and then C /= '{'
+         then
+            Write_Info_Char (C);
+
+            if C = '"' then
+               Write_Info_Char (C);
+            end if;
+
+         else
+            declare
+               Hex : constant array (0 .. 15) of Character :=
+                       "0123456789ABCDEF";
+
+            begin
+               Write_Info_Char ('{');
+               Write_Info_Char (Hex (Character'Pos (C) / 16));
+               Write_Info_Char (Hex (Character'Pos (C) mod 16));
+               Write_Info_Char ('}');
+            end;
+         end if;
+      end loop;
+
+      Write_Info_Char ('"');
+   end Write_Info_Slit;
+
    --------------------
    -- Write_Info_Str --
    --------------------
@@ -225,7 +282,16 @@  package body Lib.Util is
 
       Info_Buffer_Len := 0;
       Info_Buffer_Col := 1;
-
    end Write_Info_Terminate;
 
+   ---------------------
+   -- Write_Info_Uint --
+   ---------------------
+
+   procedure Write_Info_Uint (N : Uint) is
+   begin
+      UI_Image (N, Decimal);
+      Write_Info_Str (UI_Image_Buffer (1 .. UI_Image_Length));
+   end Write_Info_Uint;
+
 end Lib.Util;
Index: lib-util.ads
===================================================================
--- lib-util.ads	(revision 160705)
+++ lib-util.ads	(working copy)
@@ -23,6 +23,8 @@ 
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Uintp; use Uintp;
+
 package Lib.Util is
 
    --  This package implements a buffered write of library information
@@ -52,6 +54,10 @@  package Lib.Util is
    procedure Write_Info_Nat (N : Nat);
    --  Adds image of N to Info_Buffer with no leading or trailing blanks
 
+   procedure Write_Info_Int (N : Int);
+   --  Adds image of N to Info_Buffer with no leading or trailing blanks. A
+   --  minus sign is prepended for negative values.
+
    procedure Write_Info_Name (Name : Name_Id);
    procedure Write_Info_Name (Name : File_Name_Type);
    procedure Write_Info_Name (Name : Unit_Name_Type);
@@ -59,6 +65,9 @@  package Lib.Util is
    --  name is written literally from the names table entry without modifying
    --  the case, using simply Get_Name_String.
 
+   procedure Write_Info_Slit (S : String_Id);
+   --  Write string literal value in format required for L/N lines in ali file
+
    procedure Write_Info_Str (Val : String);
    --  Adds characters of Val to Info_Buffer surrounded by quotes
 
@@ -70,4 +79,8 @@  package Lib.Util is
    procedure Write_Info_Terminate;
    --  Terminate current info line and output lines built in Info_Buffer
 
+   procedure Write_Info_Uint (N : Uint);
+   --  Adds decimal image of N to Info_Buffer with no leading or trailing
+   --  blanks. A minus sign is prepended for negative values.
+
 end Lib.Util;