------------------------------------------------------------------------------ -- -- -- GNAT SYSTEM UTILITIES -- -- -- -- X S N A M E S T -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2018, 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 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 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. This version reads a template file from snames.ads-tmpl in -- which the numbers are all written as $, and generates a new version of the -- spec file snames.ads (written to snames.ns). It also reads snames.adb-tmpl -- and generates an updated body (written to snames.nb), and snames.h-tmpl and -- generates an updated C header file (written to snames.nh). with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO; with Ada.Strings.Maps; use Ada.Strings.Maps; with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; with Ada.Text_IO; use Ada.Text_IO; with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; with GNAT.Spitbol; use GNAT.Spitbol; with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; with XUtil; use XUtil; procedure XSnamesT is subtype VString is GNAT.Spitbol.VString; InS : Ada.Text_IO.File_Type; InB : Ada.Text_IO.File_Type; InH : Ada.Text_IO.File_Type; OutS : Ada.Streams.Stream_IO.File_Type; OutB : Ada.Streams.Stream_IO.File_Type; OutH : Ada.Streams.Stream_IO.File_Type; A, B : VString := Nul; Line : VString := Nul; Name0 : VString := Nul; Name1 : VString := Nul; Oval : VString := Nul; Restl : VString := Nul; Name_Ref : constant Pattern := Span (' ') * A & Break (' ') * Name0 & Span (' ') * B & ": constant Name_Id := N + $;" & Rest * Restl; 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 : constant Character_Mapping := To_Mapping ("u", "_"); M : Match_Result; type Header_Symbol is (None, Name, Attr, Conv, Prag); -- A symbol in the header file procedure Output_Header_Line (S : Header_Symbol); -- Output header line Header_Name : aliased String := "Name"; 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_Name'Access, 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, 0); Header_Current_Symbol : Header_Symbol := None; Header_Pending_Line : VString := Nul; ------------------------ -- Output_Header_Line -- ------------------------ procedure Output_Header_Line (S : Header_Symbol) is function Make_Value (V : Integer) return String; -- Build the definition for the current macro (Names are integers -- offset to N, while other items are enumeration values). ---------------- -- Make_Value -- ---------------- function Make_Value (V : Integer) return String is begin if S = Name then return "(First_Name_Id + 256 + " & V & ")"; else return "" & V; end if; end Make_Value; -- Start of processing for Output_Header_Line 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 Name2 : VString; Pat : constant Pattern := "#define " & Header_Prefix (S).all & Break (' ') * Name2; 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 -- Note that we must ensure at least one space between macro name and -- parens, otherwise the parenthesized value gets treated as an argument -- specification. Put_Line (OutH, "#define " & Header_Prefix (S).all & "_" & Name1 & (30 - Natural'Min (29, Length (Name1))) * ' ' & Make_Value (Header_Counter (S))); Header_Counter (S) := Header_Counter (S) + 1; end Output_Header_Line; -- Start of processing for XSnames begin Open (InS, In_File, "snames.ads-tmpl"); Open (InB, In_File, "snames.adb-tmpl"); Open (InH, In_File, "snames.h-tmpl"); -- Note that we do not generate snames.{ads,adb,h} directly. Instead -- we output them to snames.n{s,b,h} so that Makefiles can use -- move-if-change to not touch previously generated files if the -- new ones are identical. Create (OutS, Out_File, "snames.ns"); Create (OutB, Out_File, "snames.nb"); Create (OutH, Out_File, "snames.nh"); Put_Line (OutH, "#ifdef __cplusplus"); Put_Line (OutH, "extern ""C"" {"); Put_Line (OutH, "#endif"); Anchored_Mode := True; Val := 0; loop Line := Get_Line (InB); exit when Match (Line, " Preset_Names"); Put_Line (OutB, Line); end loop; Put_Line (OutB, Line); LoopN : while not End_Of_File (InS) loop Line := Get_Line (InS); 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 if Match (Name0, "Last_") then Oval := Lpad (V (Val - 1), 3, '0'); else Oval := Lpad (V (Val), 3, '0'); end if; Put_Line (OutS, A & Name0 & B & ": constant Name_Id := N + " & Oval & ';' & Restl); if Match (Name0, Get_Name) then Name0 := Name1; Val := Val + 1; if Match (Name0, Findu, M) then Replace (M, Translate (A, Xlate_U_Und)); Translate (Name0, Lower_Case_Map); elsif not Match (Name0, "Op_", "") then Translate (Name0, Lower_Case_Map); else Name0 := 'O' & Translate (Name0, Lower_Case_Map); end if; if not Match (Name0, Chk_Low) then Put_Line (OutB, " """ & Name0 & "#"" &"); end if; Output_Header_Line (Name); end if; end if; end loop LoopN; loop Line := Get_Line (InB); exit when Match (Line, " ""#"";"); end loop; Put_Line (OutB, Line); while not End_Of_File (InB) loop 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; Put_Line (OutH, "#ifdef __cplusplus"); Put_Line (OutH, "}"); Put_Line (OutH, "#endif"); end XSnamesT;