-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
--- This utility is used to make a new version of the Snames package when
--- new names are added to the spec, the existing versions of snames.ads and
--- snames.adb are read, and updated to match the set of names in snames.ads.
--- The updated versions are written to snames.ns and snames.nb (new spec/body)
+-- This utility is used to make a new version of the Snames package when new
+-- names are added to the spec, the existing versions of snames.ads and
+-- snames.adb and snames.h are read, and updated to match the set of names in
+-- snames.ads. The updated versions are written to snames.ns, snames.nb (new
+-- spec/body), and snames.nh (new header file).
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
InS : File_Type;
OutS : File_Type;
OutB : File_Type;
+ InH : File_Type;
+ OutH : File_Type;
- A, B : VString := Nul;
- Line : VString := Nul;
- Name : VString := Nul;
- Name1 : VString := Nul;
- Oname : VString := Nul;
- Oval : VString := Nul;
- Restl : VString := Nul;
+ A, B : VString := Nul;
+ Line : VString := Nul;
+ Name : VString := Nul;
+ Name1 : VString := Nul;
+ Oval : VString := Nul;
+ Restl : VString := Nul;
- Tdigs : Pattern := Any (Decimal_Digit_Set) &
- Any (Decimal_Digit_Set) &
- Any (Decimal_Digit_Set);
+ Tdigs : constant Pattern := Any (Decimal_Digit_Set) &
+ Any (Decimal_Digit_Set) &
+ Any (Decimal_Digit_Set);
- Name_Ref : Pattern := Span (' ') * A & Break (' ') * Name
- & Span (' ') * B
- & ": constant Name_Id := N + " & Tdigs
- & ';' & Rest * Restl;
+ Name_Ref : constant Pattern := Span (' ') * A & Break (' ') * Name
+ & Span (' ') * B
+ & ": constant Name_Id := N + " & Tdigs
+ & ';' & Rest * Restl;
- Get_Name : Pattern := "Name_" & Rest * Name1;
-
- Chk_Low : Pattern := Pos (0) & Any (Lower_Set) & Rest & Pos (1);
-
- Findu : Pattern := Span ('u') * A;
+ Get_Name : constant Pattern := "Name_" & Rest * Name1;
+ Chk_Low : constant Pattern := Pos (0) & Any (Lower_Set) & Rest & Pos (1);
+ Findu : constant Pattern := Span ('u') * A;
Val : Natural;
- Xlate_U_Und : Character_Mapping := To_Mapping ("u", "_");
+ Xlate_U_Und : constant Character_Mapping := To_Mapping ("u", "_");
M : Match_Result;
+ type Header_Symbol is (None, Attr, Conv, Prag);
+ -- A symbol in the header file
+
+ procedure Output_Header_Line (S : Header_Symbol);
+ -- Output header line
+
+ Header_Attr : aliased String := "Attr";
+ Header_Conv : aliased String := "Convention";
+ Header_Prag : aliased String := "Pragma";
+ -- Prefixes used in the header file
+
+ type String_Ptr is access all String;
+ Header_Prefix : constant array (Header_Symbol) of String_Ptr :=
+ (null,
+ Header_Attr'Access,
+ Header_Conv'Access,
+ Header_Prag'Access);
+
+ -- Patterns used in the spec file
+
+ Get_Attr : constant Pattern := Span (' ') & "Attribute_"
+ & Break (",)") * Name1;
+ Get_Conv : constant Pattern := Span (' ') & "Convention_"
+ & Break (",)") * Name1;
+ Get_Prag : constant Pattern := Span (' ') & "Pragma_"
+ & Break (",)") * Name1;
+
+ type Header_Symbol_Counter is array (Header_Symbol) of Natural;
+ Header_Counter : Header_Symbol_Counter := (0, 0, 0, 0);
+
+ Header_Current_Symbol : Header_Symbol := None;
+ Header_Pending_Line : VString := Nul;
+
+ ------------------------
+ -- Output_Header_Line --
+ ------------------------
+
+ procedure Output_Header_Line (S : Header_Symbol) is
+ begin
+ -- Skip all the #define for S-prefixed symbols in the header.
+ -- Of course we are making implicit assumptions:
+ -- (1) No newline between symbols with the same prefix.
+ -- (2) Prefix order is the same as in snames.ads.
+
+ if Header_Current_Symbol /= S then
+ declare
+ Pat : constant String := "#define " & Header_Prefix (S).all;
+ In_Pat : Boolean := False;
+
+ begin
+ if Header_Current_Symbol /= None then
+ Put_Line (OutH, Header_Pending_Line);
+ end if;
+
+ loop
+ Line := Get_Line (InH);
+
+ if Match (Line, Pat) then
+ In_Pat := True;
+ elsif In_Pat then
+ Header_Pending_Line := Line;
+ exit;
+ else
+ Put_Line (OutH, Line);
+ end if;
+ end loop;
+
+ Header_Current_Symbol := S;
+ end;
+ end if;
+
+ -- Now output the line
+
+ Put_Line (OutH, "#define " & Header_Prefix (S).all
+ & "_" & Name1 & (30 - Length (Name1)) * ' '
+ & Header_Counter (S));
+ Header_Counter (S) := Header_Counter (S) + 1;
+ end Output_Header_Line;
+
+-- Start of processing for XSnames
+
begin
Open (InB, In_File, "snames.adb");
Open (InS, In_File, "snames.ads");
+ Open (InH, In_File, "snames.h");
Create (OutS, Out_File, "snames.ns");
Create (OutB, Out_File, "snames.nb");
+ Create (OutH, Out_File, "snames.nh");
Anchored_Mode := True;
- Oname := Nul;
Val := 0;
loop
if not Match (Line, Name_Ref) then
Put_Line (OutS, Line);
+ if Match (Line, Get_Attr) then
+ Output_Header_Line (Attr);
+ elsif Match (Line, Get_Conv) then
+ Output_Header_Line (Conv);
+ elsif Match (Line, Get_Prag) then
+ Output_Header_Line (Prag);
+ end if;
else
Oval := Lpad (V (Val), 3, '0');
Put_Line (OutB, Line);
while not End_Of_File (InB) loop
- Put_Line (OutB, Get_Line (InB));
+ Line := Get_Line (InB);
+ Put_Line (OutB, Line);
+ end loop;
+
+ Put_Line (OutH, Header_Pending_Line);
+ while not End_Of_File (InH) loop
+ Line := Get_Line (InH);
+ Put_Line (OutH, Line);
end loop;
end XSnames;
OSDN Git Service
