Mercurial > hg > CbC > CbC_gcc
comparison gcc/ada/xtreeprs.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 T R E E P R S -- | |
6 -- -- | |
7 -- B o d y -- | |
8 -- -- | |
9 -- Copyright (C) 1992-2010, 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 -- Program to construct the spec of the Treeprs package | |
27 | |
28 -- Input files: | |
29 | |
30 -- sinfo.ads Spec of Sinfo package | |
31 -- treeprs.adt Template for Treeprs package | |
32 | |
33 -- Output files: | |
34 | |
35 -- treeprs.ads Spec of Treeprs package | |
36 | |
37 -- Note: this program assumes that sinfo.ads has passed the error checks which | |
38 -- are carried out by the CSinfo utility so it does not duplicate these checks | |
39 | |
40 -- An optional argument allows the specification of an output file name to | |
41 -- override the default treeprs.ads file name for the generated output file. | |
42 | |
43 with Ada.Command_Line; use Ada.Command_Line; | |
44 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; | |
45 with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO; | |
46 with Ada.Text_IO; use Ada.Text_IO; | |
47 with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; | |
48 | |
49 with GNAT.Spitbol; use GNAT.Spitbol; | |
50 with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns; | |
51 with GNAT.Spitbol.Table_Boolean; use GNAT.Spitbol.Table_Boolean; | |
52 with GNAT.Spitbol.Table_VString; use GNAT.Spitbol.Table_VString; | |
53 | |
54 procedure XTreeprs is | |
55 | |
56 package TB renames GNAT.Spitbol.Table_Boolean; | |
57 package TV renames GNAT.Spitbol.Table_VString; | |
58 | |
59 Err : exception; | |
60 -- Raised on fatal error | |
61 | |
62 A : VString := Nul; | |
63 Ffield : VString := Nul; | |
64 Field : VString := Nul; | |
65 Fieldno : VString := Nul; | |
66 Flagno : VString := Nul; | |
67 Line : VString := Nul; | |
68 Name : VString := Nul; | |
69 Node : VString := Nul; | |
70 Outstring : VString := Nul; | |
71 Prefix : VString := Nul; | |
72 S : VString := Nul; | |
73 S1 : VString := Nul; | |
74 Syn : VString := Nul; | |
75 Synonym : VString := Nul; | |
76 Term : VString := Nul; | |
77 | |
78 subtype Sfile is Ada.Streams.Stream_IO.File_Type; | |
79 | |
80 OutS : Sfile; | |
81 -- Output file | |
82 | |
83 InS : Ada.Text_IO.File_Type; | |
84 -- Read sinfo.ads | |
85 | |
86 InT : Ada.Text_IO.File_Type; | |
87 -- Read treeprs.adt | |
88 | |
89 Special : TB.Table (20); | |
90 -- Table of special fields. These fields are not included in the table | |
91 -- constructed by Xtreeprs, since they are specially handled in treeprs. | |
92 -- This means these field definitions are completely ignored. | |
93 | |
94 Names : array (1 .. 500) of VString; | |
95 -- Table of names of synonyms | |
96 | |
97 Positions : array (1 .. 500) of Natural; | |
98 -- Table of starting positions in Pchars string for synonyms | |
99 | |
100 Strings : TV.Table (300); | |
101 -- Contribution of each synonym to Pchars string, indexed by name | |
102 | |
103 Count : Natural := 0; | |
104 -- Number of synonyms processed so far | |
105 | |
106 Curpos : Natural := 1; | |
107 -- Number of characters generated in Pchars string so far | |
108 | |
109 Lineno : Natural := 0; | |
110 -- Line number in sinfo.ads | |
111 | |
112 Field_Base : constant := Character'Pos ('#'); | |
113 -- Fields 1-5 are represented by the characters #$%&' (i.e. by five | |
114 -- contiguous characters starting at # (16#23#)). | |
115 | |
116 Flag_Base : constant := Character'Pos ('('); | |
117 -- Flags 1-18 are represented by the characters ()*+,-./0123456789 | |
118 -- (i.e. by 18 contiguous characters starting at (16#28#)). | |
119 | |
120 Fieldch : Character; | |
121 -- Field character, as per above tables | |
122 | |
123 Sp : aliased Natural; | |
124 -- Space left on line for Pchars output | |
125 | |
126 wsp : constant Pattern := Span (' ' & ASCII.HT); | |
127 Is_Temp : constant Pattern := BreakX ('T') * A & "T e m p l a t e"; | |
128 Get_Node : constant Pattern := wsp & "-- N_" & Rest * Node; | |
129 Tst_Punc : constant Pattern := Break (" ,."); | |
130 Get_Syn : constant Pattern := Span (' ') & "-- " & Break (' ') * Synonym | |
131 & " (" & Break (')') * Field; | |
132 Brk_Min : constant Pattern := Break ('-') * Ffield; | |
133 Is_Flag : constant Pattern := "Flag" & Rest * Flagno; | |
134 Is_Field : constant Pattern := Rtab (1) & Len (1) * Fieldno; | |
135 Is_Syn : constant Pattern := wsp & "N_" & Break (",)") * Syn | |
136 & Len (1) * Term; | |
137 Brk_Node : constant Pattern := Break (' ') * Node & ' '; | |
138 Chop_SP : constant Pattern := Len (Sp'Unrestricted_Access) * S1; | |
139 | |
140 M : Match_Result; | |
141 | |
142 procedure Put_Line (F : Sfile; S : String); | |
143 procedure Put_Line (F : Sfile; S : VString); | |
144 -- Local version of Put_Line ensures Unix style line endings | |
145 | |
146 procedure Put_Line (F : Sfile; S : String) is | |
147 begin | |
148 String'Write (Stream (F), S); | |
149 Character'Write (Stream (F), ASCII.LF); | |
150 end Put_Line; | |
151 | |
152 procedure Put_Line (F : Sfile; S : VString) is | |
153 begin | |
154 Put_Line (F, To_String (S)); | |
155 end Put_Line; | |
156 | |
157 -- Start of processing for XTreeprs | |
158 | |
159 begin | |
160 Anchored_Mode := True; | |
161 | |
162 if Argument_Count > 0 then | |
163 Create (OutS, Out_File, Argument (1)); | |
164 else | |
165 Create (OutS, Out_File, "treeprs.ads"); | |
166 end if; | |
167 | |
168 Open (InS, In_File, "sinfo.ads"); | |
169 Open (InT, In_File, "treeprs.adt"); | |
170 | |
171 -- Initialize special fields table | |
172 | |
173 Set (Special, "Analyzed", True); | |
174 Set (Special, "Cannot_Be_Constant", True); | |
175 Set (Special, "Chars", True); | |
176 Set (Special, "Comes_From_Source", True); | |
177 Set (Special, "Error_Posted", True); | |
178 Set (Special, "Etype", True); | |
179 Set (Special, "Has_No_Side_Effects", True); | |
180 Set (Special, "Is_Controlling_Actual", True); | |
181 Set (Special, "Is_Overloaded", True); | |
182 Set (Special, "Is_Static_Expression", True); | |
183 Set (Special, "Left_Opnd", True); | |
184 Set (Special, "Must_Check_Expr", True); | |
185 Set (Special, "No_Overflow_Expr", True); | |
186 Set (Special, "Paren_Count", True); | |
187 Set (Special, "Raises_Constraint_Error", True); | |
188 Set (Special, "Right_Opnd", True); | |
189 | |
190 -- Read template header and generate new header | |
191 | |
192 loop | |
193 Line := Get_Line (InT); | |
194 | |
195 -- Skip lines describing the template | |
196 | |
197 if Match (Line, "-- This file is a template") then | |
198 loop | |
199 Line := Get_Line (InT); | |
200 exit when Line = ""; | |
201 end loop; | |
202 end if; | |
203 | |
204 exit when Match (Line, "package"); | |
205 | |
206 if Match (Line, Is_Temp, M) then | |
207 Replace (M, A & " S p e c "); | |
208 end if; | |
209 | |
210 Put_Line (OutS, Line); | |
211 end loop; | |
212 | |
213 Put_Line (OutS, Line); | |
214 | |
215 -- Copy rest of comments up to template insert point to spec | |
216 | |
217 loop | |
218 Line := Get_Line (InT); | |
219 exit when Match (Line, "!!TEMPLATE INSERTION POINT"); | |
220 Put_Line (OutS, Line); | |
221 end loop; | |
222 | |
223 -- Here we are doing the actual insertions | |
224 | |
225 Put_Line (OutS, " Pchars : constant String :="); | |
226 | |
227 -- Loop through comments describing nodes, picking up fields | |
228 | |
229 loop | |
230 Line := Get_Line (InS); | |
231 Lineno := Lineno + 1; | |
232 exit when Match (Line, " type Node_Kind"); | |
233 | |
234 if Match (Line, Get_Node) | |
235 and then not Match (Node, Tst_Punc) | |
236 then | |
237 Outstring := Node & ' '; | |
238 | |
239 loop | |
240 Line := Get_Line (InS); | |
241 exit when Line = ""; | |
242 | |
243 if Match (Line, Get_Syn) | |
244 and then not Match (Synonym, "plus") | |
245 and then not Present (Special, Synonym) | |
246 then | |
247 -- Convert this field into the character used to | |
248 -- represent the field according to the table: | |
249 | |
250 -- Field1 '#' | |
251 -- Field2 '$' | |
252 -- Field3 '%' | |
253 -- Field4 '&' | |
254 -- Field5 "'" | |
255 -- Flag4 '+' | |
256 -- Flag5 ',' | |
257 -- Flag6 '-' | |
258 -- Flag7 '.' | |
259 -- Flag8 '/' | |
260 -- Flag9 '0' | |
261 -- Flag10 '1' | |
262 -- Flag11 '2' | |
263 -- Flag12 '3' | |
264 -- Flag13 '4' | |
265 -- Flag14 '5' | |
266 -- Flag15 '6' | |
267 -- Flag16 '7' | |
268 -- Flag17 '8' | |
269 -- Flag18 '9' | |
270 | |
271 if Match (Field, Brk_Min) then | |
272 Field := Ffield; | |
273 end if; | |
274 | |
275 if Match (Field, Is_Flag) then | |
276 Fieldch := Char (Flag_Base - 1 + N (Flagno)); | |
277 | |
278 elsif Match (Field, Is_Field) then | |
279 Fieldch := Char (Field_Base - 1 + N (Fieldno)); | |
280 | |
281 else | |
282 Put_Line | |
283 (Standard_Error, | |
284 "*** Line " & | |
285 Lineno & | |
286 " has unrecognized field name " & | |
287 Field); | |
288 raise Err; | |
289 end if; | |
290 | |
291 Append (Outstring, Fieldch & Synonym); | |
292 end if; | |
293 end loop; | |
294 | |
295 Set (Strings, Node, Outstring); | |
296 end if; | |
297 end loop; | |
298 | |
299 -- Loop through actual definitions of node kind enumeration literals | |
300 | |
301 loop | |
302 loop | |
303 Line := Get_Line (InS); | |
304 Lineno := Lineno + 1; | |
305 exit when Match (Line, Is_Syn); | |
306 end loop; | |
307 | |
308 S := Get (Strings, Syn); | |
309 Match (S, Brk_Node, ""); | |
310 Count := Count + 1; | |
311 Names (Count) := Syn; | |
312 Positions (Count) := Curpos; | |
313 Curpos := Curpos + Length (S); | |
314 Put_Line (OutS, " -- " & Node); | |
315 Prefix := V (" "); | |
316 exit when Term = ")"; | |
317 | |
318 -- Loop to output the string literal for Pchars | |
319 | |
320 loop | |
321 Sp := 79 - 4 - Length (Prefix); | |
322 exit when Size (S) <= Sp; | |
323 Match (S, Chop_SP, ""); | |
324 Put_Line (OutS, Prefix & '"' & S1 & """ &"); | |
325 Prefix := V (" "); | |
326 end loop; | |
327 | |
328 Put_Line (OutS, Prefix & '"' & S & """ &"); | |
329 end loop; | |
330 | |
331 Put_Line (OutS, " """";"); | |
332 Put_Line (OutS, ""); | |
333 Put_Line | |
334 (OutS, " type Pchar_Pos_Array is array (Node_Kind) of Positive;"); | |
335 Put_Line | |
336 (OutS, | |
337 " Pchar_Pos : constant Pchar_Pos_Array := Pchar_Pos_Array'("); | |
338 | |
339 -- Output lines for Pchar_Pos_Array values | |
340 | |
341 for M in 1 .. Count - 1 loop | |
342 Name := Rpad ("N_" & Names (M), 40); | |
343 Put_Line (OutS, " " & Name & " => " & Positions (M) & ','); | |
344 end loop; | |
345 | |
346 Name := Rpad ("N_" & Names (Count), 40); | |
347 Put_Line (OutS, " " & Name & " => " & Positions (Count) & ");"); | |
348 | |
349 Put_Line (OutS, ""); | |
350 Put_Line (OutS, "end Treeprs;"); | |
351 | |
352 exception | |
353 when Err => | |
354 Put_Line (Standard_Error, "*** fatal error"); | |
355 Set_Exit_Status (1); | |
356 | |
357 end XTreeprs; |