1 ------------------------------------------------------------------------------
3 -- GNAT SYSTEM UTILITIES --
10 -- Copyright (C) 1992-2001 Free Software Foundation, Inc.
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
26 ------------------------------------------------------------------------------
28 -- Program to construct the spec of the Treeprs package
32 -- sinfo.ads Spec of Sinfo package
33 -- treeprs.adt Template for Treeprs package
37 -- treeprs.ads Spec of Treeprs package
39 -- Note: this program assumes that sinfo.ads has passed the error checks which
40 -- are carried out by the CSinfo utility so it does not duplicate these checks
42 -- An optional argument allows the specification of an output file name to
43 -- override the default treeprs.ads file name for the generated output file.
45 with Ada
.Command_Line
; use Ada
.Command_Line
;
46 with Ada
.Strings
.Unbounded
; use Ada
.Strings
.Unbounded
;
47 with Ada
.Strings
.Unbounded
.Text_IO
; use Ada
.Strings
.Unbounded
.Text_IO
;
48 with Ada
.Text_IO
; use Ada
.Text_IO
;
50 with GNAT
.Spitbol
; use GNAT
.Spitbol
;
51 with GNAT
.Spitbol
.Patterns
; use GNAT
.Spitbol
.Patterns
;
52 with GNAT
.Spitbol
.Table_Boolean
; use GNAT
.Spitbol
.Table_Boolean
;
53 with GNAT
.Spitbol
.Table_VString
; use GNAT
.Spitbol
.Table_VString
;
57 package TB
renames GNAT
.Spitbol
.Table_Boolean
;
58 package TV
renames GNAT
.Spitbol
.Table_VString
;
61 -- Raised on fatal error
64 Ffield
: VString
:= Nul
;
65 Field
: VString
:= Nul
;
66 Fieldno
: VString
:= Nul
;
67 Flagno
: VString
:= Nul
;
68 Line
: VString
:= Nul
;
69 Name
: VString
:= Nul
;
70 Node
: VString
:= Nul
;
71 Outstring
: VString
:= Nul
;
72 Prefix
: VString
:= Nul
;
76 Synonym
: VString
:= Nul
;
77 Term
: VString
:= Nul
;
88 Special
: TB
.Table
(20);
89 -- Table of special fields. These fields are not included in the table
90 -- constructed by Xtreeprs, since they are specially handled in treeprs.
91 -- This means these field definitions are completely ignored.
93 Names
: array (1 .. 500) of VString
;
94 -- Table of names of synonyms
96 Positions
: array (1 .. 500) of Natural;
97 -- Table of starting positions in Pchars string for synonyms
99 Strings
: TV
.Table
(300);
100 -- Contribution of each synonym to Pchars string, indexed by name
102 Count
: Natural := 0;
103 -- Number of synonyms processed so far
105 Curpos
: Natural := 1;
106 -- Number of characters generated in Pchars string so far
108 Lineno
: Natural := 0;
109 -- Line number in sinfo.ads
111 Field_Base
: constant := Character'Pos ('#');
112 -- Fields 1-5 are represented by the characters #$%&' (i.e. by five
113 -- contiguous characters starting at # (16#23#)).
115 Flag_Base
: constant := Character'Pos ('(');
116 -- Flags 1-18 are represented by the characters ()*+,-./0123456789
117 -- (i.e. by 18 contiguous characters starting at (16#28#)).
120 -- Field character, as per above tables
122 Sp
: aliased Natural;
123 -- Space left on line for Pchars output
125 wsp
: Pattern
:= Span
(' ' & ASCII
.HT
);
127 Is_Temp
: Pattern
:= BreakX
('T') * A
& "T e m p l a t e";
128 Get_Node
: Pattern
:= wsp
& "-- N_" & Rest
* Node
;
129 Tst_Punc
: Pattern
:= Break
(" ,.");
130 Get_Syn
: Pattern
:= Span
(' ') & "-- " & Break
(' ') * Synonym
131 & " (" & Break
(')') * Field
;
132 Brk_Min
: Pattern
:= Break
('-') * Ffield
;
133 Is_Flag
: Pattern
:= "Flag" & Rest
* Flagno
;
134 Is_Field
: Pattern
:= Rtab
(1) & Len
(1) * Fieldno
;
135 Is_Syn
: Pattern
:= wsp
& "N_" & Break
(",)") * Syn
& Len
(1) * Term
;
136 Brk_Node
: Pattern
:= Break
(' ') * Node
& ' ';
137 Chop_SP
: Pattern
:= Len
(Sp
'Unrestricted_Access) * S1
;
142 Anchored_Mode
:= True;
144 if Argument_Count
> 0 then
145 Create
(OutS
, Out_File
, Argument
(1));
147 Create
(OutS
, Out_File
, "treeprs.ads");
150 Open
(InS
, In_File
, "sinfo.ads");
151 Open
(InT
, In_File
, "treeprs.adt");
153 -- Initialize special fields table
155 Set
(Special
, "Analyzed", True);
156 Set
(Special
, "Cannot_Be_Constant", True);
157 Set
(Special
, "Chars", True);
158 Set
(Special
, "Comes_From_Source", True);
159 Set
(Special
, "Error_Posted", True);
160 Set
(Special
, "Etype", True);
161 Set
(Special
, "Has_No_Side_Effects", True);
162 Set
(Special
, "Is_Controlling_Actual", True);
163 Set
(Special
, "Is_Overloaded", True);
164 Set
(Special
, "Is_Static_Expression", True);
165 Set
(Special
, "Left_Opnd", True);
166 Set
(Special
, "Must_Check_Expr", True);
167 Set
(Special
, "No_Overflow_Expr", True);
168 Set
(Special
, "Paren_Count", True);
169 Set
(Special
, "Raises_Constraint_Error", True);
170 Set
(Special
, "Right_Opnd", True);
172 -- Read template header and generate new header
175 Line
:= Get_Line
(InT
);
177 -- Skip lines describing the template
179 if Match
(Line
, "-- This file is a template") then
181 Line
:= Get_Line
(InT
);
186 exit when Match
(Line
, "package");
188 if Match
(Line
, Is_Temp
, M
) then
189 Replace
(M
, A
& " S p e c ");
192 Put_Line
(OutS
, Line
);
195 Put_Line
(OutS
, Line
);
197 -- Copy rest of comments up to template insert point to spec
200 Line
:= Get_Line
(InT
);
201 exit when Match
(Line
, "!!TEMPLATE INSERTION POINT");
202 Put_Line
(OutS
, Line
);
205 -- Here we are doing the actual insertions
207 Put_Line
(OutS
, " Pchars : constant String :=");
209 -- Loop through comments describing nodes, picking up fields
212 Line
:= Get_Line
(InS
);
213 Lineno
:= Lineno
+ 1;
214 exit when Match
(Line
, " type Node_Kind");
216 if Match
(Line
, Get_Node
)
217 and then not Match
(Node
, Tst_Punc
)
219 Outstring
:= Node
& ' ';
222 Line
:= Get_Line
(InS
);
225 if Match
(Line
, Get_Syn
)
226 and then not Match
(Synonym
, "plus")
227 and then not Present
(Special
, Synonym
)
229 -- Convert this field into the character used to
230 -- represent the field according to the table:
256 if Match
(Field
, Brk_Min
) then
260 if Match
(Field
, Is_Flag
) then
261 Fieldch
:= Char
(Flag_Base
- 1 + N
(Flagno
));
263 elsif Match
(Field
, Is_Field
) then
264 Fieldch
:= Char
(Field_Base
- 1 + N
(Fieldno
));
271 " has unrecognized field name " &
276 Append
(Outstring
, Fieldch
& Synonym
);
280 Set
(Strings
, Node
, Outstring
);
284 -- Loop through actual definitions of node kind enumeration literals
288 Line
:= Get_Line
(InS
);
289 Lineno
:= Lineno
+ 1;
290 exit when Match
(Line
, Is_Syn
);
293 S
:= Get
(Strings
, Syn
);
294 Match
(S
, Brk_Node
, "");
296 Names
(Count
) := Syn
;
297 Positions
(Count
) := Curpos
;
298 Curpos
:= Curpos
+ Length
(S
);
299 Put_Line
(OutS
, " -- " & Node
);
301 exit when Term
= ")";
303 -- Loop to output the string literal for Pchars
306 Sp
:= 79 - 4 - Length
(Prefix
);
307 exit when (Size
(S
) <= Sp
);
308 Match
(S
, Chop_SP
, "");
309 Put_Line
(OutS
, Prefix
& '"' & S1
& """ &");
313 Put_Line
(OutS
, Prefix
& '"' & S
& """ &");
316 Put_Line
(OutS
, " """";");
319 (OutS
, " type Pchar_Pos_Array is array (Node_Kind) of Positive;");
322 " Pchar_Pos : constant Pchar_Pos_Array := Pchar_Pos_Array'(");
324 -- Output lines for Pchar_Pos_Array values
326 for M
in 1 .. Count
- 1 loop
327 Name
:= Rpad
("N_" & Names
(M
), 40);
328 Put_Line
(OutS
, " " & Name
& " => " & Positions
(M
) & ',');
331 Name
:= Rpad
("N_" & Names
(Count
), 40);
332 Put_Line
(OutS
, " " & Name
& " => " & Positions
(Count
) & ");");
335 Put_Line
(OutS
, "end Treeprs;");
339 Put_Line
(Standard_Error
, "*** fatal error");