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