OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [xtreeprs.adb] - Blame information for rev 320

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
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-2008, 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
 
43
with Ada.Command_Line;              use Ada.Command_Line;
44
with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
45
with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
46
with Ada.Text_IO;                   use Ada.Text_IO;
47
with Ada.Streams.Stream_IO;         use Ada.Streams.Stream_IO;
48
 
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;
53
 
54
procedure 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
 
159
begin
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
               --    Flag1        "("
256
               --    Flag2        ")"
257
               --    Flag3        '*'
258
               --    Flag4        '+'
259
               --    Flag5        ','
260
               --    Flag6        '-'
261
               --    Flag7        '.'
262
               --    Flag8        '/'
263
               --    Flag9        '0'
264
               --    Flag10       '1'
265
               --    Flag11       '2'
266
               --    Flag12       '3'
267
               --    Flag13       '4'
268
               --    Flag14       '5'
269
               --    Flag15       '6'
270
               --    Flag16       '7'
271
               --    Flag17       '8'
272
               --    Flag18       '9'
273
 
274
               if Match (Field, Brk_Min) then
275
                  Field := Ffield;
276
               end if;
277
 
278
               if Match (Field, Is_Flag) then
279
                  Fieldch := Char (Flag_Base - 1 + N (Flagno));
280
 
281
               elsif Match (Field, Is_Field) then
282
                  Fieldch := Char (Field_Base - 1 + N (Fieldno));
283
 
284
               else
285
                  Put_Line
286
                    (Standard_Error,
287
                     "*** Line " &
288
                      Lineno &
289
                      " has unrecognized field name " &
290
                      Field);
291
                  raise Err;
292
               end if;
293
 
294
               Append (Outstring, Fieldch & Synonym);
295
            end if;
296
         end loop;
297
 
298
         Set (Strings, Node, Outstring);
299
      end if;
300
   end loop;
301
 
302
   --  Loop through actual definitions of node kind enumeration literals
303
 
304
   loop
305
      loop
306
         Line := Get_Line (InS);
307
         Lineno := Lineno + 1;
308
         exit when Match (Line, Is_Syn);
309
      end loop;
310
 
311
      S := Get (Strings, Syn);
312
      Match (S, Brk_Node, "");
313
      Count := Count + 1;
314
      Names (Count) := Syn;
315
      Positions (Count) := Curpos;
316
      Curpos := Curpos + Length (S);
317
      Put_Line (OutS, "      --  " & Node);
318
      Prefix := V ("      ");
319
      exit when Term = ")";
320
 
321
      --  Loop to output the string literal for Pchars
322
 
323
      loop
324
         Sp := 79 - 4 - Length (Prefix);
325
         exit when Size (S) <= Sp;
326
         Match (S, Chop_SP, "");
327
         Put_Line (OutS, Prefix & '"' & S1 & """ &");
328
         Prefix := V ("         ");
329
      end loop;
330
 
331
      Put_Line (OutS, Prefix & '"' & S & """ &");
332
   end loop;
333
 
334
   Put_Line (OutS, "      """";");
335
   Put_Line (OutS, "");
336
   Put_Line
337
     (OutS, "   type Pchar_Pos_Array is array (Node_Kind) of Positive;");
338
   Put_Line
339
     (OutS,
340
      "   Pchar_Pos : constant Pchar_Pos_Array := Pchar_Pos_Array'(");
341
 
342
   --  Output lines for Pchar_Pos_Array values
343
 
344
   for M in 1 .. Count - 1 loop
345
      Name := Rpad ("N_" & Names (M), 40);
346
      Put_Line (OutS, "      " & Name & " => " & Positions (M) & ',');
347
   end loop;
348
 
349
   Name := Rpad ("N_" & Names (Count), 40);
350
   Put_Line (OutS, "      " & Name & " => " & Positions (Count) & ");");
351
 
352
   Put_Line (OutS, "");
353
   Put_Line (OutS, "end Treeprs;");
354
 
355
exception
356
   when Err =>
357
      Put_Line (Standard_Error, "*** fatal error");
358
      Set_Exit_Status (1);
359
 
360
end XTreeprs;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.