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
43with Ada.Command_Line;              use Ada.Command_Line;
44with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
45with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
46with Ada.Text_IO;                   use Ada.Text_IO;
47with Ada.Streams.Stream_IO;         use Ada.Streams.Stream_IO;
48
49with GNAT.Spitbol;                  use GNAT.Spitbol;
50with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
51with GNAT.Spitbol.Table_Boolean;    use GNAT.Spitbol.Table_Boolean;
52with GNAT.Spitbol.Table_VString;    use GNAT.Spitbol.Table_VString;
53
54procedure 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
159begin
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
352exception
353   when Err =>
354      Put_Line (Standard_Error, "*** fatal error");
355      Set_Exit_Status (1);
356
357end XTreeprs;
358