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
);