Mercurial > hg > CbC > CbC_gcc
comparison gcc/ada/xsnamest.adb @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
1 ------------------------------------------------------------------------------ | |
2 -- -- | |
3 -- GNAT SYSTEM UTILITIES -- | |
4 -- -- | |
5 -- X S N A M E S T -- | |
6 -- -- | |
7 -- B o d y -- | |
8 -- -- | |
9 -- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- | |
10 -- -- | |
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. -- | |
20 -- -- | |
21 -- GNAT was originally developed by the GNAT team at New York University. -- | |
22 -- Extensive contributions were provided by Ada Core Technologies Inc. -- | |
23 -- -- | |
24 ------------------------------------------------------------------------------ | |
25 | |
26 -- This utility is used to make a new version of the Snames package when new | |
27 -- names are added. This version reads a template file from snames.ads-tmpl in | |
28 -- which the numbers are all written as $, and generates a new version of the | |
29 -- spec file snames.ads (written to snames.ns). It also reads snames.adb-tmpl | |
30 -- and generates an updated body (written to snames.nb), and snames.h-tmpl and | |
31 -- generates an updated C header file (written to snames.nh). | |
32 | |
33 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; | |
34 with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO; | |
35 with Ada.Strings.Maps; use Ada.Strings.Maps; | |
36 with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; | |
37 with Ada.Text_IO; use Ada.Text_IO; | |
38 with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; | |
39 | |
40 with GNAT.Spitbol; use GNAT.Spitbol; | |
41 with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; | |
42 | |
43 with XUtil; use XUtil; | |
44 | |
45 procedure XSnamesT is | |
46 | |
47 subtype VString is GNAT.Spitbol.VString; | |
48 | |
49 InS : Ada.Text_IO.File_Type; | |
50 InB : Ada.Text_IO.File_Type; | |
51 InH : Ada.Text_IO.File_Type; | |
52 | |
53 OutS : Ada.Streams.Stream_IO.File_Type; | |
54 OutB : Ada.Streams.Stream_IO.File_Type; | |
55 OutH : Ada.Streams.Stream_IO.File_Type; | |
56 | |
57 A, B : VString := Nul; | |
58 Line : VString := Nul; | |
59 Name0 : VString := Nul; | |
60 Name1 : VString := Nul; | |
61 Oval : VString := Nul; | |
62 Restl : VString := Nul; | |
63 | |
64 Name_Ref : constant Pattern := Span (' ') * A & Break (' ') * Name0 | |
65 & Span (' ') * B | |
66 & ": constant Name_Id := N + $;" | |
67 & Rest * Restl; | |
68 | |
69 Get_Name : constant Pattern := "Name_" & Rest * Name1; | |
70 Chk_Low : constant Pattern := Pos (0) & Any (Lower_Set) & Rest & Pos (1); | |
71 Findu : constant Pattern := Span ('u') * A; | |
72 | |
73 Val : Natural; | |
74 | |
75 Xlate_U_Und : constant Character_Mapping := To_Mapping ("u", "_"); | |
76 | |
77 M : Match_Result; | |
78 | |
79 type Header_Symbol is (None, Name, Attr, Conv, Prag); | |
80 -- A symbol in the header file | |
81 | |
82 procedure Output_Header_Line (S : Header_Symbol); | |
83 -- Output header line | |
84 | |
85 Header_Name : aliased String := "Name"; | |
86 Header_Attr : aliased String := "Attr"; | |
87 Header_Conv : aliased String := "Convention"; | |
88 Header_Prag : aliased String := "Pragma"; | |
89 -- Prefixes used in the header file | |
90 | |
91 type String_Ptr is access all String; | |
92 Header_Prefix : constant array (Header_Symbol) of String_Ptr := | |
93 (null, | |
94 Header_Name'Access, | |
95 Header_Attr'Access, | |
96 Header_Conv'Access, | |
97 Header_Prag'Access); | |
98 | |
99 -- Patterns used in the spec file | |
100 | |
101 Get_Attr : constant Pattern := Span (' ') & "Attribute_" | |
102 & Break (",)") * Name1; | |
103 Get_Conv : constant Pattern := Span (' ') & "Convention_" | |
104 & Break (",)") * Name1; | |
105 Get_Prag : constant Pattern := Span (' ') & "Pragma_" | |
106 & Break (",)") * Name1; | |
107 | |
108 type Header_Symbol_Counter is array (Header_Symbol) of Natural; | |
109 Header_Counter : Header_Symbol_Counter := (0, 0, 0, 0, 0); | |
110 | |
111 Header_Current_Symbol : Header_Symbol := None; | |
112 Header_Pending_Line : VString := Nul; | |
113 | |
114 ------------------------ | |
115 -- Output_Header_Line -- | |
116 ------------------------ | |
117 | |
118 procedure Output_Header_Line (S : Header_Symbol) is | |
119 function Make_Value (V : Integer) return String; | |
120 -- Build the definition for the current macro (Names are integers | |
121 -- offset to N, while other items are enumeration values). | |
122 | |
123 ---------------- | |
124 -- Make_Value -- | |
125 ---------------- | |
126 | |
127 function Make_Value (V : Integer) return String is | |
128 begin | |
129 if S = Name then | |
130 return "(First_Name_Id + 256 + " & V & ")"; | |
131 else | |
132 return "" & V; | |
133 end if; | |
134 end Make_Value; | |
135 | |
136 -- Start of processing for Output_Header_Line | |
137 | |
138 begin | |
139 -- Skip all the #define for S-prefixed symbols in the header. | |
140 -- Of course we are making implicit assumptions: | |
141 -- (1) No newline between symbols with the same prefix. | |
142 -- (2) Prefix order is the same as in snames.ads. | |
143 | |
144 if Header_Current_Symbol /= S then | |
145 declare | |
146 Name2 : VString; | |
147 Pat : constant Pattern := "#define " | |
148 & Header_Prefix (S).all | |
149 & Break (' ') * Name2; | |
150 In_Pat : Boolean := False; | |
151 | |
152 begin | |
153 if Header_Current_Symbol /= None then | |
154 Put_Line (OutH, Header_Pending_Line); | |
155 end if; | |
156 | |
157 loop | |
158 Line := Get_Line (InH); | |
159 | |
160 if Match (Line, Pat) then | |
161 In_Pat := True; | |
162 elsif In_Pat then | |
163 Header_Pending_Line := Line; | |
164 exit; | |
165 else | |
166 Put_Line (OutH, Line); | |
167 end if; | |
168 end loop; | |
169 | |
170 Header_Current_Symbol := S; | |
171 end; | |
172 end if; | |
173 | |
174 -- Now output the line | |
175 | |
176 -- Note that we must ensure at least one space between macro name and | |
177 -- parens, otherwise the parenthesized value gets treated as an argument | |
178 -- specification. | |
179 | |
180 Put_Line (OutH, "#define " & Header_Prefix (S).all | |
181 & "_" & Name1 | |
182 & (30 - Natural'Min (29, Length (Name1))) * ' ' | |
183 & Make_Value (Header_Counter (S))); | |
184 Header_Counter (S) := Header_Counter (S) + 1; | |
185 end Output_Header_Line; | |
186 | |
187 -- Start of processing for XSnames | |
188 | |
189 begin | |
190 Open (InS, In_File, "snames.ads-tmpl"); | |
191 Open (InB, In_File, "snames.adb-tmpl"); | |
192 Open (InH, In_File, "snames.h-tmpl"); | |
193 | |
194 -- Note that we do not generate snames.{ads,adb,h} directly. Instead | |
195 -- we output them to snames.n{s,b,h} so that Makefiles can use | |
196 -- move-if-change to not touch previously generated files if the | |
197 -- new ones are identical. | |
198 | |
199 Create (OutS, Out_File, "snames.ns"); | |
200 Create (OutB, Out_File, "snames.nb"); | |
201 Create (OutH, Out_File, "snames.nh"); | |
202 | |
203 Put_Line (OutH, "#ifdef __cplusplus"); | |
204 Put_Line (OutH, "extern ""C"" {"); | |
205 Put_Line (OutH, "#endif"); | |
206 | |
207 Anchored_Mode := True; | |
208 Val := 0; | |
209 | |
210 loop | |
211 Line := Get_Line (InB); | |
212 exit when Match (Line, " Preset_Names"); | |
213 Put_Line (OutB, Line); | |
214 end loop; | |
215 | |
216 Put_Line (OutB, Line); | |
217 | |
218 LoopN : while not End_Of_File (InS) loop | |
219 Line := Get_Line (InS); | |
220 | |
221 if not Match (Line, Name_Ref) then | |
222 Put_Line (OutS, Line); | |
223 | |
224 if Match (Line, Get_Attr) then | |
225 Output_Header_Line (Attr); | |
226 elsif Match (Line, Get_Conv) then | |
227 Output_Header_Line (Conv); | |
228 elsif Match (Line, Get_Prag) then | |
229 Output_Header_Line (Prag); | |
230 end if; | |
231 else | |
232 | |
233 if Match (Name0, "Last_") then | |
234 Oval := Lpad (V (Val - 1), 3, '0'); | |
235 else | |
236 Oval := Lpad (V (Val), 3, '0'); | |
237 end if; | |
238 | |
239 Put_Line | |
240 (OutS, A & Name0 & B & ": constant Name_Id := N + " | |
241 & Oval & ';' & Restl); | |
242 | |
243 if Match (Name0, Get_Name) then | |
244 Name0 := Name1; | |
245 Val := Val + 1; | |
246 | |
247 if Match (Name0, Findu, M) then | |
248 Replace (M, Translate (A, Xlate_U_Und)); | |
249 Translate (Name0, Lower_Case_Map); | |
250 | |
251 elsif not Match (Name0, "Op_", "") then | |
252 Translate (Name0, Lower_Case_Map); | |
253 | |
254 else | |
255 Name0 := 'O' & Translate (Name0, Lower_Case_Map); | |
256 end if; | |
257 | |
258 if not Match (Name0, Chk_Low) then | |
259 Put_Line (OutB, " """ & Name0 & "#"" &"); | |
260 end if; | |
261 | |
262 Output_Header_Line (Name); | |
263 end if; | |
264 end if; | |
265 end loop LoopN; | |
266 | |
267 loop | |
268 Line := Get_Line (InB); | |
269 exit when Match (Line, " ""#"";"); | |
270 end loop; | |
271 | |
272 Put_Line (OutB, Line); | |
273 | |
274 while not End_Of_File (InB) loop | |
275 Line := Get_Line (InB); | |
276 Put_Line (OutB, Line); | |
277 end loop; | |
278 | |
279 Put_Line (OutH, Header_Pending_Line); | |
280 while not End_Of_File (InH) loop | |
281 Line := Get_Line (InH); | |
282 Put_Line (OutH, Line); | |
283 end loop; | |
284 | |
285 Put_Line (OutH, "#ifdef __cplusplus"); | |
286 Put_Line (OutH, "}"); | |
287 Put_Line (OutH, "#endif"); | |
288 end XSnamesT; |