From patchwork Mon Jun 14 13:01:51 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 55527 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 110D11007D2 for ; Mon, 14 Jun 2010 23:01:56 +1000 (EST) Received: (qmail 4799 invoked by alias); 14 Jun 2010 13:01:54 -0000 Received: (qmail 4216 invoked by uid 22791); 14 Jun 2010 13:01:50 -0000 X-SWARE-Spam-Status: No, hits=-0.5 required=5.0 tests=AWL, BAYES_50, TW_RG, T_RP_MATCHES_RCVD, WEIRD_QUOTING X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (212.99.106.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Mon, 14 Jun 2010 13:01:42 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 3F4D8CB021B; Mon, 14 Jun 2010 15:01:44 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id m6lNvEdXt479; Mon, 14 Jun 2010 15:01:44 +0200 (CEST) Received: from saumur.act-europe.fr (saumur.act-europe.fr [10.10.0.183]) by mel.act-europe.fr (Postfix) with ESMTP id 29E06CB0219; Mon, 14 Jun 2010 15:01:44 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id 4F755D9B31; Mon, 14 Jun 2010 15:01:51 +0200 (CEST) Date: Mon, 14 Jun 2010 15:01:51 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Robert Dewar Subject: [Ada] Implement notes lines in ALI file Message-ID: <20100614130151.GA4590@adacore.com> Mime-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.9i X-IsSubscribed: yes Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org 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 * 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 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 (""); + 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 [:] ... + + -- x is one of: + -- A pragma Annotate + -- C pragma Comment + -- I pragma Ident + -- T pragma Title + -- S pragma Subtitle + + -- 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 followed by a colon. + + -- 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 "" + --------------------- -- 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 x [:] ... - - -- x is one of: - -- A pragma Annotate - -- C pragma Comment - -- I pragma Ident - -- T pragma Title - -- S pragma Subtitle - - -- is the source file containing the pragma by its dependency index - -- (first D line has index 1) - -- 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 followed by a colon. - - -- 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 "" - --------------------------------- -- 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;