summaryrefslogtreecommitdiff
path: root/gcc/ada/xtreeprs.adb
blob: e6433845f80785c201a16f02ec8417afe81b9444 (plain)
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
------------------------------------------------------------------------------
--                                                                          --
--                          GNAT SYSTEM UTILITIES                           --
--                                                                          --
--                             X T R E E P R S                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                                                                          --
--          Copyright (C) 1992-2001 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 2,  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 COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
--                                                                          --
------------------------------------------------------------------------------

--  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 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;

   OutS : File_Type;
   --  Output file

   InS : File_Type;
   --  Read sinfo.ads

   InT : 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 : Pattern := Span (' ' & ASCII.HT);

   Is_Temp  : Pattern := BreakX ('T') * A & "T e m p l a t e";
   Get_Node : Pattern := wsp & "--  N_" & Rest * Node;
   Tst_Punc : Pattern := Break (" ,.");
   Get_Syn  : Pattern := Span (' ') & "--  " & Break (' ') * Synonym
                & " (" & Break (')') * Field;
   Brk_Min  : Pattern := Break ('-') * Ffield;
   Is_Flag  : Pattern := "Flag" & Rest * Flagno;
   Is_Field : Pattern := Rtab (1) & Len (1) * Fieldno;
   Is_Syn   : Pattern := wsp & "N_" & Break (",)") * Syn & Len (1) * Term;
   Brk_Node : Pattern := Break (' ') * Node & ' ';
   Chop_SP  : Pattern := Len (Sp'Unrestricted_Access) * S1;

   M : Match_Result;

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       "'"
               --    Flag1        "("
               --    Flag2        ")"
               --    Flag3        '*'
               --    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;