1 ------------------------------------------------------------------------------
3 -- GNAT SYSTEM UTILITIES --
9 -- Copyright (C) 1992-2008, 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 Oval : VString := Nul;
55 Restl : VString := Nul;
57 Tdigs : constant Pattern := Any (Decimal_Digit_Set) &
58 Any (Decimal_Digit_Set) &
59 Any (Decimal_Digit_Set);
61 Name_Ref : constant Pattern := Span (' ') * A & Break (' ') * Name
63 & ": constant Name_Id := N + " & Tdigs
66 Get_Name : constant Pattern := "Name_" & Rest * Name1;
67 Chk_Low : constant Pattern := Pos (0) & Any (Lower_Set) & Rest & Pos (1);
68 Findu : constant Pattern := Span ('u') * A;
72 Xlate_U_Und : constant Character_Mapping := To_Mapping ("u", "_");
76 type Header_Symbol is (None, Attr, Conv, Prag);
77 -- A symbol in the header file
79 procedure Output_Header_Line (S : Header_Symbol);
82 Header_Attr : aliased String := "Attr";
83 Header_Conv : aliased String := "Convention";
84 Header_Prag : aliased String := "Pragma";
85 -- Prefixes used in the header file
87 type String_Ptr is access all String;
88 Header_Prefix : constant array (Header_Symbol) of String_Ptr :=
94 -- Patterns used in the spec file
96 Get_Attr : constant Pattern := Span (' ') & "Attribute_"
97 & Break (",)") * Name1;
98 Get_Conv : constant Pattern := Span (' ') & "Convention_"
99 & Break (",)") * Name1;
100 Get_Prag : constant Pattern := Span (' ') & "Pragma_"
101 & Break (",)") * Name1;
103 type Header_Symbol_Counter is array (Header_Symbol) of Natural;
104 Header_Counter : Header_Symbol_Counter := (0, 0, 0, 0);
106 Header_Current_Symbol : Header_Symbol := None;
107 Header_Pending_Line : VString := Nul;
109 ------------------------
110 -- Output_Header_Line --
111 ------------------------
113 procedure Output_Header_Line (S : Header_Symbol) is
115 -- Skip all the #define for S-prefixed symbols in the header.
116 -- Of course we are making implicit assumptions:
117 -- (1) No newline between symbols with the same prefix.
118 -- (2) Prefix order is the same as in snames.ads.
120 if Header_Current_Symbol /= S then
122 Pat : constant String := "#define " & Header_Prefix (S).all;
123 In_Pat : Boolean := False;
126 if Header_Current_Symbol /= None then
127 Put_Line (OutH, Header_Pending_Line);
131 Line := Get_Line (InH);
133 if Match (Line, Pat) then
136 Header_Pending_Line := Line;
139 Put_Line (OutH, Line);
143 Header_Current_Symbol := S;
147 -- Now output the line
149 Put_Line (OutH, "#define " & Header_Prefix (S).all
150 & "_" & Name1 & (30 - Length (Name1)) * ' '
151 & Header_Counter (S));
152 Header_Counter (S) := Header_Counter (S) + 1;
153 end Output_Header_Line;
155 -- Start of processing for XSnames
158 Open (InB, In_File, "snames.adb");
159 Open (InS, In_File, "snames.ads");
160 Open (InH, In_File, "snames.h");
162 Create (OutS, Out_File, "snames.ns");
163 Create (OutB, Out_File, "snames.nb");
164 Create (OutH, Out_File, "snames.nh");
166 Anchored_Mode := True;
170 Line := Get_Line (InB);
171 exit when Match (Line, " Preset_Names");
172 Put_Line (OutB, Line);
175 Put_Line (OutB, Line);
177 LoopN : while not End_Of_File (InS) loop
178 Line := Get_Line (InS);
180 if not Match (Line, Name_Ref) then
181 Put_Line (OutS, Line);
183 if Match (Line, Get_Attr) then
184 Output_Header_Line (Attr);
185 elsif Match (Line, Get_Conv) then
186 Output_Header_Line (Conv);
187 elsif Match (Line, Get_Prag) then
188 Output_Header_Line (Prag);
191 Oval := Lpad (V (Val), 3, '0');
193 if Match (Name, "Last_") then
194 Oval := Lpad (V (Val - 1), 3, '0');
198 (OutS, A & Name & B & ": constant Name_Id := N + "
199 & Oval & ';' & Restl);
201 if Match (Name, Get_Name) then
205 if Match (Name, Findu, M) then
206 Replace (M, Translate (A, Xlate_U_Und));
207 Translate (Name, Lower_Case_Map);
209 elsif not Match (Name, "Op_", "") then
210 Translate (Name, Lower_Case_Map);
213 Name := 'O' & Translate (Name, Lower_Case_Map);
216 if Name = "error" then
217 Name := V ("<error>");
220 if not Match (Name, Chk_Low) then
221 Put_Line (OutB, " """ & Name & "#"" &");
228 Line := Get_Line (InB);
229 exit when Match (Line, " ""#"";");
232 Put_Line (OutB, Line);
234 while not End_Of_File (InB) loop
235 Line := Get_Line (InB);
236 Put_Line (OutB, Line);
239 Put_Line (OutH, Header_Pending_Line);
240 while not End_Of_File (InH) loop
241 Line := Get_Line (InH);
242 Put_Line (OutH, Line);