File : xtreeprs.adb
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;