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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [xsnamest.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                          GNAT SYSTEM UTILITIES                           --
4
--                                                                          --
5
--                             X S N A M E S T                              --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2011, 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
--  This utility is used to make a new version of the Snames package when new
27
--  names are added. This version reads a template file from snames.ads-tmpl in
28
--  which the numbers are all written as $, and generates a new version of the
29
--  spec file snames.ads (written to snames.ns). It also reads snames.adb-tmpl
30
--  and generates an updated body (written to snames.nb), and snames.h-tmpl and
31
--  generates an updated C header file (written to snames.nh).
32
 
33
with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
34
with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
35
with Ada.Strings.Maps;              use Ada.Strings.Maps;
36
with Ada.Strings.Maps.Constants;    use Ada.Strings.Maps.Constants;
37
with Ada.Text_IO;                   use Ada.Text_IO;
38
with Ada.Streams.Stream_IO;         use Ada.Streams.Stream_IO;
39
 
40
with GNAT.Spitbol;                  use GNAT.Spitbol;
41
with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
42
 
43
with XUtil;                         use XUtil;
44
 
45
procedure XSnamesT is
46
 
47
   subtype VString is GNAT.Spitbol.VString;
48
 
49
   InS  : Ada.Text_IO.File_Type;
50
   InB  : Ada.Text_IO.File_Type;
51
   InH  : Ada.Text_IO.File_Type;
52
 
53
   OutS : Ada.Streams.Stream_IO.File_Type;
54
   OutB : Ada.Streams.Stream_IO.File_Type;
55
   OutH : Ada.Streams.Stream_IO.File_Type;
56
 
57
   A, B  : VString := Nul;
58
   Line  : VString := Nul;
59
   Name0 : VString := Nul;
60
   Name1 : VString := Nul;
61
   Oval  : VString := Nul;
62
   Restl : VString := Nul;
63
 
64
   Name_Ref : constant Pattern := Span (' ') * A & Break (' ') * Name0
65
                                  & Span (' ') * B
66
                                  & ": constant Name_Id := N + $;"
67
                                  & Rest * Restl;
68
 
69
   Get_Name : constant Pattern := "Name_" & Rest * Name1;
70
   Chk_Low  : constant Pattern := Pos (0) & Any (Lower_Set) & Rest & Pos (1);
71
   Findu    : constant Pattern := Span ('u') * A;
72
 
73
   Val : Natural;
74
 
75
   Xlate_U_Und : constant Character_Mapping := To_Mapping ("u", "_");
76
 
77
   M : Match_Result;
78
 
79
   type Header_Symbol is (None, Name, Attr, Conv, Prag);
80
   --  A symbol in the header file
81
 
82
   procedure Output_Header_Line (S : Header_Symbol);
83
   --  Output header line
84
 
85
   Header_Name : aliased String := "Name";
86
   Header_Attr : aliased String := "Attr";
87
   Header_Conv : aliased String := "Convention";
88
   Header_Prag : aliased String := "Pragma";
89
   --  Prefixes used in the header file
90
 
91
   type String_Ptr is access all String;
92
   Header_Prefix : constant array (Header_Symbol) of String_Ptr :=
93
                     (null,
94
                      Header_Name'Access,
95
                      Header_Attr'Access,
96
                      Header_Conv'Access,
97
                      Header_Prag'Access);
98
 
99
   --  Patterns used in the spec file
100
 
101
   Get_Attr : constant Pattern := Span (' ') & "Attribute_"
102
                                  & Break (",)") * Name1;
103
   Get_Conv : constant Pattern := Span (' ') & "Convention_"
104
                                  & Break (",)") * Name1;
105
   Get_Prag : constant Pattern := Span (' ') & "Pragma_"
106
                                  & Break (",)") * Name1;
107
 
108
   type Header_Symbol_Counter is array (Header_Symbol) of Natural;
109
   Header_Counter : Header_Symbol_Counter := (0, 0, 0, 0, 0);
110
 
111
   Header_Current_Symbol : Header_Symbol := None;
112
   Header_Pending_Line : VString := Nul;
113
 
114
   ------------------------
115
   -- Output_Header_Line --
116
   ------------------------
117
 
118
   procedure Output_Header_Line (S : Header_Symbol) is
119
      function Make_Value (V : Integer) return String;
120
      --  Build the definition for the current macro (Names are integers
121
      --  offset to N, while other items are enumeration values).
122
 
123
      function Make_Value (V : Integer) return String is
124
      begin
125
         if S = Name then
126
            return "(First_Name_Id + 256 + " & V & ")";
127
         else
128
            return "" & V;
129
         end if;
130
      end Make_Value;
131
 
132
   begin
133
      --  Skip all the #define for S-prefixed symbols in the header.
134
      --  Of course we are making implicit assumptions:
135
      --   (1) No newline between symbols with the same prefix.
136
      --   (2) Prefix order is the same as in snames.ads.
137
 
138
      if Header_Current_Symbol /= S then
139
         declare
140
            Name2 : VString;
141
            Pat : constant Pattern := "#define  "
142
                                       & Header_Prefix (S).all
143
                                       & Break (' ') * Name2;
144
            In_Pat : Boolean := False;
145
 
146
         begin
147
            if Header_Current_Symbol /= None then
148
               Put_Line (OutH, Header_Pending_Line);
149
            end if;
150
 
151
            loop
152
               Line := Get_Line (InH);
153
 
154
               if Match (Line, Pat) then
155
                  In_Pat := True;
156
               elsif In_Pat then
157
                  Header_Pending_Line := Line;
158
                  exit;
159
               else
160
                  Put_Line (OutH, Line);
161
               end if;
162
            end loop;
163
 
164
            Header_Current_Symbol := S;
165
         end;
166
      end if;
167
 
168
      --  Now output the line
169
 
170
      --  Note that we must ensure at least one space between macro name and
171
      --  parens, otherwise the parenthesized value gets treated as an argument
172
      --  specification.
173
 
174
      Put_Line (OutH, "#define  " & Header_Prefix (S).all
175
                  & "_" & Name1
176
                  & (30 - Natural'Min (29, Length (Name1))) * ' '
177
                  & Make_Value (Header_Counter (S)));
178
      Header_Counter (S) := Header_Counter (S) + 1;
179
   end Output_Header_Line;
180
 
181
--  Start of processing for XSnames
182
 
183
begin
184
   Open (InS, In_File, "snames.ads-tmpl");
185
   Open (InB, In_File, "snames.adb-tmpl");
186
   Open (InH, In_File, "snames.h-tmpl");
187
 
188
   --  Note that we do not generate snames.{ads,adb,h} directly. Instead
189
   --  we output them to snames.n{s,b,h} so that Makefiles can use
190
   --  move-if-change to not touch previously generated files if the
191
   --  new ones are identical.
192
 
193
   Create (OutS, Out_File, "snames.ns");
194
   Create (OutB, Out_File, "snames.nb");
195
   Create (OutH, Out_File, "snames.nh");
196
 
197
   Put_Line (OutH, "#ifdef __cplusplus");
198
   Put_Line (OutH, "extern ""C"" {");
199
   Put_Line (OutH, "#endif");
200
 
201
   Anchored_Mode := True;
202
   Val := 0;
203
 
204
   loop
205
      Line := Get_Line (InB);
206
      exit when Match (Line, "   Preset_Names");
207
      Put_Line (OutB, Line);
208
   end loop;
209
 
210
   Put_Line (OutB, Line);
211
 
212
   LoopN : while not End_Of_File (InS) loop
213
      Line := Get_Line (InS);
214
 
215
      if not Match (Line, Name_Ref) then
216
         Put_Line (OutS, Line);
217
 
218
         if Match (Line, Get_Attr) then
219
            Output_Header_Line (Attr);
220
         elsif Match (Line, Get_Conv) then
221
            Output_Header_Line (Conv);
222
         elsif Match (Line, Get_Prag) then
223
            Output_Header_Line (Prag);
224
         end if;
225
      else
226
         Oval := Lpad (V (Val), 3, '0');
227
 
228
         if Match (Name0, "Last_") then
229
            Oval := Lpad (V (Val - 1), 3, '0');
230
         end if;
231
 
232
         Put_Line
233
           (OutS, A & Name0 & B & ": constant Name_Id := N + "
234
            & Oval & ';' & Restl);
235
 
236
         if Match (Name0, Get_Name) then
237
            Name0 := Name1;
238
            Val   := Val + 1;
239
 
240
            if Match (Name0, Findu, M) then
241
               Replace (M, Translate (A, Xlate_U_Und));
242
               Translate (Name0, Lower_Case_Map);
243
 
244
            elsif not Match (Name0, "Op_", "") then
245
               Translate (Name0, Lower_Case_Map);
246
 
247
            else
248
               Name0 := 'O' & Translate (Name0, Lower_Case_Map);
249
            end if;
250
 
251
            if Name0 = "error" then
252
               Name0 := V ("<error>");
253
            end if;
254
 
255
            if not Match (Name0, Chk_Low) then
256
               Put_Line (OutB, "     """ & Name0 & "#"" &");
257
            end if;
258
 
259
            Output_Header_Line (Name);
260
         end if;
261
      end if;
262
   end loop LoopN;
263
 
264
   loop
265
      Line := Get_Line (InB);
266
      exit when Match (Line, "     ""#"";");
267
   end loop;
268
 
269
   Put_Line (OutB, Line);
270
 
271
   while not End_Of_File (InB) loop
272
      Line := Get_Line (InB);
273
      Put_Line (OutB, Line);
274
   end loop;
275
 
276
   Put_Line (OutH, Header_Pending_Line);
277
   while not End_Of_File (InH) loop
278
      Line := Get_Line (InH);
279
      Put_Line (OutH, Line);
280
   end loop;
281
 
282
   Put_Line (OutH, "#ifdef __cplusplus");
283
   Put_Line (OutH, "}");
284
   Put_Line (OutH, "#endif");
285
end XSnamesT;

powered by: WebSVN 2.1.0

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