===================================================================
@@ -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 --
-------------------------------
===================================================================
@@ -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
===================================================================
@@ -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;
===================================================================
@@ -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 --
---------------------------------
===================================================================
@@ -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;
===================================================================
@@ -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
===================================================================
@@ -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 --
-------------------------------------------
===================================================================
@@ -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;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- 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;
===================================================================
@@ -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;
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