Mark ChangeLog
[official-gcc.git] / gcc / ada / xtreeprs.adb
blob2e026d101630de040b9b976d68bab9c0d9c0038d
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-2004 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
27 -- Program to construct the spec of the Treeprs package
29 -- Input files:
31 -- sinfo.ads Spec of Sinfo package
32 -- treeprs.adt Template for Treeprs package
34 -- Output files:
36 -- treeprs.ads Spec of Treeprs package
38 -- Note: this program assumes that sinfo.ads has passed the error checks which
39 -- are carried out by the CSinfo utility so it does not duplicate these checks
41 -- An optional argument allows the specification of an output file name to
42 -- override the default treeprs.ads file name for the generated output file.
44 with Ada.Command_Line; use Ada.Command_Line;
45 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
46 with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
47 with Ada.Text_IO; use Ada.Text_IO;
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;
54 procedure XTreeprs is
56 package TB renames GNAT.Spitbol.Table_Boolean;
57 package TV renames GNAT.Spitbol.Table_VString;
59 Err : exception;
60 -- Raised on fatal error
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;
78 OutS : File_Type;
79 -- Output file
81 InS : File_Type;
82 -- Read sinfo.ads
84 InT : File_Type;
85 -- Read treeprs.adt
87 Special : TB.Table (20);
88 -- Table of special fields. These fields are not included in the table
89 -- constructed by Xtreeprs, since they are specially handled in treeprs.
90 -- This means these field definitions are completely ignored.
92 Names : array (1 .. 500) of VString;
93 -- Table of names of synonyms
95 Positions : array (1 .. 500) of Natural;
96 -- Table of starting positions in Pchars string for synonyms
98 Strings : TV.Table (300);
99 -- Contribution of each synonym to Pchars string, indexed by name
101 Count : Natural := 0;
102 -- Number of synonyms processed so far
104 Curpos : Natural := 1;
105 -- Number of characters generated in Pchars string so far
107 Lineno : Natural := 0;
108 -- Line number in sinfo.ads
110 Field_Base : constant := Character'Pos ('#');
111 -- Fields 1-5 are represented by the characters #$%&' (i.e. by five
112 -- contiguous characters starting at # (16#23#)).
114 Flag_Base : constant := Character'Pos ('(');
115 -- Flags 1-18 are represented by the characters ()*+,-./0123456789
116 -- (i.e. by 18 contiguous characters starting at (16#28#)).
118 Fieldch : Character;
119 -- Field character, as per above tables
121 Sp : aliased Natural;
122 -- Space left on line for Pchars output
124 wsp : Pattern := Span (' ' & ASCII.HT);
126 Is_Temp : Pattern := BreakX ('T') * A & "T e m p l a t e";
127 Get_Node : Pattern := wsp & "-- N_" & Rest * Node;
128 Tst_Punc : Pattern := Break (" ,.");
129 Get_Syn : Pattern := Span (' ') & "-- " & Break (' ') * Synonym
130 & " (" & Break (')') * Field;
131 Brk_Min : Pattern := Break ('-') * Ffield;
132 Is_Flag : Pattern := "Flag" & Rest * Flagno;
133 Is_Field : Pattern := Rtab (1) & Len (1) * Fieldno;
134 Is_Syn : Pattern := wsp & "N_" & Break (",)") * Syn & Len (1) * Term;
135 Brk_Node : Pattern := Break (' ') * Node & ' ';
136 Chop_SP : Pattern := Len (Sp'Unrestricted_Access) * S1;
138 M : Match_Result;
140 begin
141 Anchored_Mode := True;
143 if Argument_Count > 0 then
144 Create (OutS, Out_File, Argument (1));
145 else
146 Create (OutS, Out_File, "treeprs.ads");
147 end if;
149 Open (InS, In_File, "sinfo.ads");
150 Open (InT, In_File, "treeprs.adt");
152 -- Initialize special fields table
154 Set (Special, "Analyzed", True);
155 Set (Special, "Cannot_Be_Constant", True);
156 Set (Special, "Chars", True);
157 Set (Special, "Comes_From_Source", True);
158 Set (Special, "Error_Posted", True);
159 Set (Special, "Etype", True);
160 Set (Special, "Has_No_Side_Effects", True);
161 Set (Special, "Is_Controlling_Actual", True);
162 Set (Special, "Is_Overloaded", True);
163 Set (Special, "Is_Static_Expression", True);
164 Set (Special, "Left_Opnd", True);
165 Set (Special, "Must_Check_Expr", True);
166 Set (Special, "No_Overflow_Expr", True);
167 Set (Special, "Paren_Count", True);
168 Set (Special, "Raises_Constraint_Error", True);
169 Set (Special, "Right_Opnd", True);
171 -- Read template header and generate new header
173 loop
174 Line := Get_Line (InT);
176 -- Skip lines describing the template
178 if Match (Line, "-- This file is a template") then
179 loop
180 Line := Get_Line (InT);
181 exit when Line = "";
182 end loop;
183 end if;
185 exit when Match (Line, "package");
187 if Match (Line, Is_Temp, M) then
188 Replace (M, A & " S p e c ");
189 end if;
191 Put_Line (OutS, Line);
192 end loop;
194 Put_Line (OutS, Line);
196 -- Copy rest of comments up to template insert point to spec
198 loop
199 Line := Get_Line (InT);
200 exit when Match (Line, "!!TEMPLATE INSERTION POINT");
201 Put_Line (OutS, Line);
202 end loop;
204 -- Here we are doing the actual insertions
206 Put_Line (OutS, " Pchars : constant String :=");
208 -- Loop through comments describing nodes, picking up fields
210 loop
211 Line := Get_Line (InS);
212 Lineno := Lineno + 1;
213 exit when Match (Line, " type Node_Kind");
215 if Match (Line, Get_Node)
216 and then not Match (Node, Tst_Punc)
217 then
218 Outstring := Node & ' ';
220 loop
221 Line := Get_Line (InS);
222 exit when Line = "";
224 if Match (Line, Get_Syn)
225 and then not Match (Synonym, "plus")
226 and then not Present (Special, Synonym)
227 then
228 -- Convert this field into the character used to
229 -- represent the field according to the table:
231 -- Field1 '#'
232 -- Field2 '$'
233 -- Field3 '%'
234 -- Field4 '&'
235 -- Field5 "'"
236 -- Flag1 "("
237 -- Flag2 ")"
238 -- Flag3 '*'
239 -- Flag4 '+'
240 -- Flag5 ','
241 -- Flag6 '-'
242 -- Flag7 '.'
243 -- Flag8 '/'
244 -- Flag9 '0'
245 -- Flag10 '1'
246 -- Flag11 '2'
247 -- Flag12 '3'
248 -- Flag13 '4'
249 -- Flag14 '5'
250 -- Flag15 '6'
251 -- Flag16 '7'
252 -- Flag17 '8'
253 -- Flag18 '9'
255 if Match (Field, Brk_Min) then
256 Field := Ffield;
257 end if;
259 if Match (Field, Is_Flag) then
260 Fieldch := Char (Flag_Base - 1 + N (Flagno));
262 elsif Match (Field, Is_Field) then
263 Fieldch := Char (Field_Base - 1 + N (Fieldno));
265 else
266 Put_Line
267 (Standard_Error,
268 "*** Line " &
269 Lineno &
270 " has unrecognized field name " &
271 Field);
272 raise Err;
273 end if;
275 Append (Outstring, Fieldch & Synonym);
276 end if;
277 end loop;
279 Set (Strings, Node, Outstring);
280 end if;
281 end loop;
283 -- Loop through actual definitions of node kind enumeration literals
285 loop
286 loop
287 Line := Get_Line (InS);
288 Lineno := Lineno + 1;
289 exit when Match (Line, Is_Syn);
290 end loop;
292 S := Get (Strings, Syn);
293 Match (S, Brk_Node, "");
294 Count := Count + 1;
295 Names (Count) := Syn;
296 Positions (Count) := Curpos;
297 Curpos := Curpos + Length (S);
298 Put_Line (OutS, " -- " & Node);
299 Prefix := V (" ");
300 exit when Term = ")";
302 -- Loop to output the string literal for Pchars
304 loop
305 Sp := 79 - 4 - Length (Prefix);
306 exit when Size (S) <= Sp;
307 Match (S, Chop_SP, "");
308 Put_Line (OutS, Prefix & '"' & S1 & """ &");
309 Prefix := V (" ");
310 end loop;
312 Put_Line (OutS, Prefix & '"' & S & """ &");
313 end loop;
315 Put_Line (OutS, " """";");
316 Put_Line (OutS, "");
317 Put_Line
318 (OutS, " type Pchar_Pos_Array is array (Node_Kind) of Positive;");
319 Put_Line
320 (OutS,
321 " Pchar_Pos : constant Pchar_Pos_Array := Pchar_Pos_Array'(");
323 -- Output lines for Pchar_Pos_Array values
325 for M in 1 .. Count - 1 loop
326 Name := Rpad ("N_" & Names (M), 40);
327 Put_Line (OutS, " " & Name & " => " & Positions (M) & ',');
328 end loop;
330 Name := Rpad ("N_" & Names (Count), 40);
331 Put_Line (OutS, " " & Name & " => " & Positions (Count) & ");");
333 Put_Line (OutS, "");
334 Put_Line (OutS, "end Treeprs;");
336 exception
337 when Err =>
338 Put_Line (Standard_Error, "*** fatal error");
339 Set_Exit_Status (1);
341 end XTreeprs;