|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT SYSTEM UTILITIES --
|
|
|
4 -- --
|
|
|
5 -- X T R E E P R S --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
|
|
111
|
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;
|
