1 ------------------------------------------------------------------------------
3 -- GNAT SYSTEM UTILITIES --
9 -- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This utility is used to make a new version of the Snames package when new
27 -- names are added to the spec, the existing versions of snames.ads and
28 -- snames.adb and snames.h are read, and updated to match the set of names in
29 -- snames.ads. The updated versions are written to snames.ns, snames.nb (new
30 -- spec/body), and snames.nh (new header file).
32 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
33 with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
34 with Ada.Strings.Maps; use Ada.Strings.Maps;
35 with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
36 with Ada.Text_IO; use Ada.Text_IO;
38 with GNAT.Spitbol; use GNAT.Spitbol;
39 with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
50 A, B : VString := Nul;
51 Line : VString := Nul;
52 Name : VString := Nul;
53 Name1 : VString := Nul;
54 Oname : VString := Nul;
55 Oval : VString := Nul;
56 Restl : VString := Nul;
58 Tdigs : Pattern := Any (Decimal_Digit_Set) &
59 Any (Decimal_Digit_Set) &
60 Any (Decimal_Digit_Set);
62 Name_Ref : Pattern := Span (' ') * A & Break (' ') * Name
64 & ": constant Name_Id := N + " & Tdigs
67 Get_Name : Pattern := "Name_" & Rest * Name1;
69 Chk_Low : Pattern := Pos (0) & Any (Lower_Set) & Rest & Pos (1);
71 Findu : Pattern := Span ('u') * A;
75 Xlate_U_Und : Character_Mapping := To_Mapping ("u", "_");
79 type Header_Symbol is (None, Attr, Conv, Prag);
80 -- A symbol in the header file
82 -- Prefixes used in the header file
84 Header_Attr : aliased String := "Attr";
85 Header_Conv : aliased String := "Convention";
86 Header_Prag : aliased String := "Pragma";
88 type String_Ptr is access all String;
89 Header_Prefix : constant array (Header_Symbol) of String_Ptr :=
95 -- Patterns used in the spec file
97 Get_Attr : Pattern := Span (' ') & "Attribute_" & Break (",)") * Name1;
98 Get_Conv : Pattern := Span (' ') & "Convention_" & Break (",)") * Name1;
99 Get_Prag : Pattern := Span (' ') & "Pragma_" & Break (",)") * Name1;
101 type Header_Symbol_Counter is array (Header_Symbol) of Natural;
102 Header_Counter : Header_Symbol_Counter := (0, 0, 0, 0);
104 Header_Current_Symbol : Header_Symbol := None;
105 Header_Pending_Line : VString := Nul;
107 ------------------------
108 -- Output_Header_Line --
109 ------------------------
111 procedure Output_Header_Line (S : Header_Symbol) is
113 -- Skip all the #define for S-prefixed symbols in the header.
114 -- Of course we are making implicit assumptions:
115 -- (1) No newline between symbols with the same prefix.
116 -- (2) Prefix order is the same as in snames.ads.
118 if Header_Current_Symbol /= S then
120 Pat : String := "#define " & Header_Prefix (S).all;
121 In_Pat : Boolean := False;
124 if Header_Current_Symbol /= None then
125 Put_Line (OutH, Header_Pending_Line);
129 Line := Get_Line (InH);
131 if Match (Line, Pat) then
134 Header_Pending_Line := Line;
137 Put_Line (OutH, Line);
141 Header_Current_Symbol := S;
145 -- Now output the line
147 Put_Line (OutH, "#define " & Header_Prefix (S).all
148 & "_" & Name1 & (30 - Length (Name1)) * ' '
149 & Header_Counter (S));
150 Header_Counter (S) := Header_Counter (S) + 1;
151 end Output_Header_Line;
153 -- Start of processing for XSnames
156 Open (InB, In_File, "snames.adb");
157 Open (InS, In_File, "snames.ads");
158 Open (InH, In_File, "snames.h");
160 Create (OutS, Out_File, "snames.ns");
161 Create (OutB, Out_File, "snames.nb");
162 Create (OutH, Out_File, "snames.nh");
164 Anchored_Mode := True;
169 Line := Get_Line (InB);
170 exit when Match (Line, " Preset_Names");
171 Put_Line (OutB, Line);
174 Put_Line (OutB, Line);
176 LoopN : while not End_Of_File (InS) loop
177 Line := Get_Line (InS);
179 if not Match (Line, Name_Ref) then
180 Put_Line (OutS, Line);
182 if Match (Line, Get_Attr) then
183 Output_Header_Line (Attr);
184 elsif Match (Line, Get_Conv) then
185 Output_Header_Line (Conv);
186 elsif Match (Line, Get_Prag) then
187 Output_Header_Line (Prag);
190 Oval := Lpad (V (Val), 3, '0');
192 if Match (Name, "Last_") then
193 Oval := Lpad (V (Val - 1), 3, '0');
197 (OutS, A & Name & B & ": constant Name_Id := N + "
198 & Oval & ';' & Restl);
200 if Match (Name, Get_Name) then
204 if Match (Name, Findu, M) then
205 Replace (M, Translate (A, Xlate_U_Und));
206 Translate (Name, Lower_Case_Map);
208 elsif not Match (Name, "Op_", "") then
209 Translate (Name, Lower_Case_Map);
212 Name := 'O' & Translate (Name, Lower_Case_Map);
215 if Name = "error" then
216 Name := V ("<error>");
219 if not Match (Name, Chk_Low) then
220 Put_Line (OutB, " """ & Name & "#"" &");
227 Line := Get_Line (InB);
228 exit when Match (Line, " ""#"";");
231 Put_Line (OutB, Line);
233 while not End_Of_File (InB) loop
234 Line := Get_Line (InB);
235 Put_Line (OutB, Line);
238 Put_Line (OutH, Header_Pending_Line);
239 while not End_Of_File (InH) loop
240 Line := Get_Line (InH);
241 Put_Line (OutH, Line);