1 ------------------------------------------------------------------------------
3 -- GNAT SYSTEM UTILITIES --
11 -- Copyright (C) 1992-2001 Free Software Foundation, Inc.
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- GNAT was originally developed by the GNAT team at New York University. --
25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
27 ------------------------------------------------------------------------------
29 -- Program to construct the spec of the Treeprs package
33 -- sinfo.ads Spec of Sinfo package
34 -- treeprs.adt Template for Treeprs package
38 -- treeprs.ads Spec of Treeprs package
40 -- Note: this program assumes that sinfo.ads has passed the error checks which
41 -- are carried out by the CSinfo utility so it does not duplicate these checks
43 -- An optional argument allows the specification of an output file name to
44 -- override the default treeprs.ads file name for the generated output file.
46 with Ada.Command_Line; use Ada.Command_Line;
47 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
48 with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
49 with Ada.Text_IO; use Ada.Text_IO;
51 with GNAT.Spitbol; use GNAT.Spitbol;
52 with GNAT.Spitbol.Patterns; use GNAT.Spitbol.Patterns;
53 with GNAT.Spitbol.Table_Boolean; use GNAT.Spitbol.Table_Boolean;
54 with GNAT.Spitbol.Table_VString; use GNAT.Spitbol.Table_VString;
58 package TB renames GNAT.Spitbol.Table_Boolean;
59 package TV renames GNAT.Spitbol.Table_VString;
62 -- Raised on fatal error
65 Ffield : VString := Nul;
66 Field : VString := Nul;
67 Fieldno : VString := Nul;
68 Flagno : VString := Nul;
69 Line : VString := Nul;
70 Name : VString := Nul;
71 Node : VString := Nul;
72 Outstring : VString := Nul;
73 Prefix : VString := Nul;
76 Sinforev : VString := Nul;
78 Synonym : VString := Nul;
79 Temprev : VString := Nul;
80 Term : VString := Nul;
81 Treeprsrev : VString := Nul;
92 Special : TB.Table (20);
93 -- Table of special fields. These fields are not included in the table
94 -- constructed by Xtreeprs, since they are specially handled in treeprs.
95 -- This means these field definitions are completely ignored.
97 Names : array (1 .. 500) of VString;
98 -- Table of names of synonyms
100 Positions : array (1 .. 500) of Natural;
101 -- Table of starting positions in Pchars string for synonyms
103 Strings : TV.Table (300);
104 -- Contribution of each synonym to Pchars string, indexed by name
106 Count : Natural := 0;
107 -- Number of synonyms processed so far
109 Curpos : Natural := 1;
110 -- Number of characters generated in Pchars string so far
112 Lineno : Natural := 0;
113 -- Line number in sinfo.ads
115 Field_Base : constant := Character'Pos ('#');
116 -- Fields 1-5 are represented by the characters #$%&' (i.e. by five
117 -- contiguous characters starting at # (16#23#)).
119 Flag_Base : constant := Character'Pos ('(');
120 -- Flags 1-18 are represented by the characters ()*+,-./0123456789
121 -- (i.e. by 18 contiguous characters starting at (16#28#)).
124 -- Field character, as per above tables
126 Sp : aliased Natural;
127 -- Space left on line for Pchars output
129 wsp : Pattern := Span (' ' & ASCII.HT);
131 Get_SRev : Pattern := BreakX ('$') & "$Rev" & "ision: "
132 & Break (' ') * Sinforev;
133 Get_TRev : Pattern := BreakX ('$') & "$Rev" & "ision: "
134 & Break (' ') * Temprev;
135 Is_Temp : Pattern := BreakX ('T') * A & "T e m p l a t e";
136 Get_Node : Pattern := wsp & "-- N_" & Rest * Node;
137 Tst_Punc : Pattern := Break (" ,.");
138 Get_Syn : Pattern := Span (' ') & "-- " & Break (' ') * Synonym
139 & " (" & Break (')') * Field;
140 Brk_Min : Pattern := Break ('-') * Ffield;
141 Is_Flag : Pattern := "Flag" & Rest * Flagno;
142 Is_Field : Pattern := Rtab (1) & Len (1) * Fieldno;
143 Is_Syn : Pattern := wsp & "N_" & Break (",)") * Syn & Len (1) * Term;
144 Brk_Node : Pattern := Break (' ') * Node & ' ';
145 Chop_SP : Pattern := Len (Sp'Unrestricted_Access) * S1;
150 Anchored_Mode := True;
152 Match ("$Revision: 1.33 $", "$Rev" & "ision: " & Break (' ') * Treeprsrev);
154 if Argument_Count > 0 then
155 Create (OutS, Out_File, Argument (1));
157 Create (OutS, Out_File, "treeprs.ads");
160 Open (InS, In_File, "sinfo.ads");
161 Open (InT, In_File, "treeprs.adt");
163 -- Initialize special fields table
165 Set (Special, "Analyzed", True);
166 Set (Special, "Cannot_Be_Constant", True);
167 Set (Special, "Chars", True);
168 Set (Special, "Comes_From_Source", True);
169 Set (Special, "Error_Posted", True);
170 Set (Special, "Etype", True);
171 Set (Special, "Has_No_Side_Effects", True);
172 Set (Special, "Is_Controlling_Actual", True);
173 Set (Special, "Is_Overloaded", True);
174 Set (Special, "Is_Static_Expression", True);
175 Set (Special, "Left_Opnd", True);
176 Set (Special, "Must_Check_Expr", True);
177 Set (Special, "No_Overflow_Expr", True);
178 Set (Special, "Paren_Count", True);
179 Set (Special, "Raises_Constraint_Error", True);
180 Set (Special, "Right_Opnd", True);
182 -- Get sinfo revs and write header to output file
185 Line := Get_Line (InS);
186 Lineno := Lineno + 1;
192 exit when Match (Line, Get_SRev);
195 -- Read template header and generate new header
198 Line := Get_Line (InT);
200 if Match (Line, Get_TRev) then
203 "-- Generated by xtreeprs revision " &
204 Treeprsrev & " using --");
208 "-- sinfo.ads revision " &
213 "-- treeprs.adt revision "
217 -- Skip lines describing the template
219 if Match (Line, "-- This file is a template") then
221 Line := Get_Line (InT);
226 exit when Match (Line, "package");
228 if Match (Line, Is_Temp, M) then
229 Replace (M, A & " S p e c ");
232 Put_Line (OutS, Line);
236 Put_Line (OutS, Line);
238 -- Copy rest of comments up to template insert point to spec
241 Line := Get_Line (InT);
242 exit when Match (Line, "!!TEMPLATE INSERTION POINT");
243 Put_Line (OutS, Line);
246 -- Here we are doing the actual insertions
248 Put_Line (OutS, " Pchars : constant String :=");
250 -- Loop through comments describing nodes, picking up fields
253 Line := Get_Line (InS);
254 Lineno := Lineno + 1;
255 exit when Match (Line, " type Node_Kind");
257 if Match (Line, Get_Node)
258 and then not Match (Node, Tst_Punc)
260 Outstring := Node & ' ';
263 Line := Get_Line (InS);
266 if Match (Line, Get_Syn)
267 and then not Match (Synonym, "plus")
268 and then not Present (Special, Synonym)
270 -- Convert this field into the character used to
271 -- represent the field according to the table:
297 if Match (Field, Brk_Min) then
301 if Match (Field, Is_Flag) then
302 Fieldch := Char (Flag_Base - 1 + N (Flagno));
304 elsif Match (Field, Is_Field) then
305 Fieldch := Char (Field_Base - 1 + N (Fieldno));
312 " has unrecognized field name " &
317 Append (Outstring, Fieldch & Synonym);
321 Set (Strings, Node, Outstring);
325 -- Loop through actual definitions of node kind enumeration literals
329 Line := Get_Line (InS);
330 Lineno := Lineno + 1;
331 exit when Match (Line, Is_Syn);
334 S := Get (Strings, Syn);
335 Match (S, Brk_Node, "");
337 Names (Count) := Syn;
338 Positions (Count) := Curpos;
339 Curpos := Curpos + Length (S);
340 Put_Line (OutS, " -- " & Node);
342 exit when Term = ")";
344 -- Loop to output the string literal for Pchars
347 Sp := 79 - 4 - Length (Prefix);
348 exit when (Size (S) <= Sp);
349 Match (S, Chop_SP, "");
350 Put_Line (OutS, Prefix & '"' & S1 & """ &");
354 Put_Line (OutS, Prefix & '"' & S & """ &");
357 Put_Line (OutS, " """";");
360 (OutS, " type Pchar_Pos_Array is array (Node_Kind) of Positive;");
363 " Pchar_Pos : constant Pchar_Pos_Array := Pchar_Pos_Array'(");
365 -- Output lines for Pchar_Pos_Array values
367 for M in 1 .. Count - 1 loop
368 Name := Rpad ("N_" & Names (M), 40);
369 Put_Line (OutS, " " & Name & " => " & Positions (M) & ',');
372 Name := Rpad ("N_" & Names (Count), 40);
373 Put_Line (OutS, " " & Name & " => " & Positions (Count) & ");");
376 Put_Line (OutS, "end Treeprs;");
380 Put_Line (Standard_Error, "*** fatal error");