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/] [xsnames.adb] - Blame information for rev 281

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                          GNAT SYSTEM UTILITIES                           --
4
--                                                                          --
5
--                              X S N A M E 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
--  This utility is used to make a new version of the Snames package when new
27
--  names are added to the spec, the existing versions of snames.ads and
28
--  snames.adb and snames.h are read, and updated to match the set of names in
29
--  snames.ads. The updated versions are written to snames.ns, snames.nb (new
30
--  spec/body), and snames.nh (new header file).
31
 
32
with Ada.Strings.Unbounded;         use Ada.Strings.Unbounded;
33
with Ada.Strings.Unbounded.Text_IO; use Ada.Strings.Unbounded.Text_IO;
34
with Ada.Strings.Maps;              use Ada.Strings.Maps;
35
with Ada.Strings.Maps.Constants;    use Ada.Strings.Maps.Constants;
36
with Ada.Text_IO;                   use Ada.Text_IO;
37
 
38
with GNAT.Spitbol;                  use GNAT.Spitbol;
39
with GNAT.Spitbol.Patterns;         use GNAT.Spitbol.Patterns;
40
 
41
procedure XSnames is
42
 
43
   InB  : File_Type;
44
   InS  : File_Type;
45
   OutS : File_Type;
46
   OutB : File_Type;
47
   InH  : File_Type;
48
   OutH : File_Type;
49
 
50
   A, B  : VString := Nul;
51
   Line  : VString := Nul;
52
   Name  : VString := Nul;
53
   Name1 : VString := Nul;
54
   Oval  : VString := Nul;
55
   Restl : VString := Nul;
56
 
57
   Tdigs : constant Pattern := Any (Decimal_Digit_Set) &
58
                               Any (Decimal_Digit_Set) &
59
                               Any (Decimal_Digit_Set);
60
 
61
   Name_Ref : constant Pattern := Span (' ') * A & Break (' ') * Name
62
                                  & Span (' ') * B
63
                                  & ": constant Name_Id := N + " & Tdigs
64
                                  & ';' & Rest * Restl;
65
 
66
   Get_Name : constant Pattern := "Name_" & Rest * Name1;
67
   Chk_Low  : constant Pattern := Pos (0) & Any (Lower_Set) & Rest & Pos (1);
68
   Findu    : constant Pattern := Span ('u') * A;
69
 
70
   Val : Natural;
71
 
72
   Xlate_U_Und : constant Character_Mapping := To_Mapping ("u", "_");
73
 
74
   M : Match_Result;
75
 
76
   type Header_Symbol is (None, Attr, Conv, Prag);
77
   --  A symbol in the header file
78
 
79
   procedure Output_Header_Line (S : Header_Symbol);
80
   --  Output header line
81
 
82
   Header_Attr : aliased String := "Attr";
83
   Header_Conv : aliased String := "Convention";
84
   Header_Prag : aliased String := "Pragma";
85
   --  Prefixes used in the header file
86
 
87
   type String_Ptr is access all String;
88
   Header_Prefix : constant array (Header_Symbol) of String_Ptr :=
89
                     (null,
90
                      Header_Attr'Access,
91
                      Header_Conv'Access,
92
                      Header_Prag'Access);
93
 
94
   --  Patterns used in the spec file
95
 
96
   Get_Attr : constant Pattern := Span (' ') & "Attribute_"
97
                                  & Break (",)") * Name1;
98
   Get_Conv : constant Pattern := Span (' ') & "Convention_"
99
                                  & Break (",)") * Name1;
100
   Get_Prag : constant Pattern := Span (' ') & "Pragma_"
101
                                  & Break (",)") * Name1;
102
 
103
   type Header_Symbol_Counter is array (Header_Symbol) of Natural;
104
   Header_Counter : Header_Symbol_Counter := (0, 0, 0, 0);
105
 
106
   Header_Current_Symbol : Header_Symbol := None;
107
   Header_Pending_Line : VString := Nul;
108
 
109
   ------------------------
110
   -- Output_Header_Line --
111
   ------------------------
112
 
113
   procedure Output_Header_Line (S : Header_Symbol) is
114
   begin
115
      --  Skip all the #define for S-prefixed symbols in the header.
116
      --  Of course we are making implicit assumptions:
117
      --   (1) No newline between symbols with the same prefix.
118
      --   (2) Prefix order is the same as in snames.ads.
119
 
120
      if Header_Current_Symbol /= S then
121
         declare
122
            Pat : constant String := "#define  " & Header_Prefix (S).all;
123
            In_Pat : Boolean := False;
124
 
125
         begin
126
            if Header_Current_Symbol /= None then
127
               Put_Line (OutH, Header_Pending_Line);
128
            end if;
129
 
130
            loop
131
               Line := Get_Line (InH);
132
 
133
               if Match (Line, Pat) then
134
                  In_Pat := True;
135
               elsif In_Pat then
136
                  Header_Pending_Line := Line;
137
                  exit;
138
               else
139
                  Put_Line (OutH, Line);
140
               end if;
141
            end loop;
142
 
143
            Header_Current_Symbol := S;
144
         end;
145
      end if;
146
 
147
      --  Now output the line
148
 
149
      Put_Line (OutH, "#define  " & Header_Prefix (S).all
150
                  & "_" & Name1 & (30 - Length (Name1)) * ' '
151
                  & Header_Counter (S));
152
      Header_Counter (S) := Header_Counter (S) + 1;
153
   end Output_Header_Line;
154
 
155
--  Start of processing for XSnames
156
 
157
begin
158
   Open (InB, In_File, "snames.adb");
159
   Open (InS, In_File, "snames.ads");
160
   Open (InH, In_File, "snames.h");
161
 
162
   Create (OutS, Out_File, "snames.ns");
163
   Create (OutB, Out_File, "snames.nb");
164
   Create (OutH, Out_File, "snames.nh");
165
 
166
   Anchored_Mode := True;
167
   Val := 0;
168
 
169
   loop
170
      Line := Get_Line (InB);
171
      exit when Match (Line, "   Preset_Names");
172
      Put_Line (OutB, Line);
173
   end loop;
174
 
175
   Put_Line (OutB, Line);
176
 
177
   LoopN : while not End_Of_File (InS) loop
178
      Line := Get_Line (InS);
179
 
180
      if not Match (Line, Name_Ref) then
181
         Put_Line (OutS, Line);
182
 
183
         if Match (Line, Get_Attr) then
184
            Output_Header_Line (Attr);
185
         elsif Match (Line, Get_Conv) then
186
            Output_Header_Line (Conv);
187
         elsif Match (Line, Get_Prag) then
188
            Output_Header_Line (Prag);
189
         end if;
190
      else
191
         Oval := Lpad (V (Val), 3, '0');
192
 
193
         if Match (Name, "Last_") then
194
            Oval := Lpad (V (Val - 1), 3, '0');
195
         end if;
196
 
197
         Put_Line
198
           (OutS, A & Name & B & ": constant Name_Id := N + "
199
            & Oval & ';' & Restl);
200
 
201
         if Match (Name, Get_Name) then
202
            Name := Name1;
203
            Val := Val + 1;
204
 
205
            if Match (Name, Findu, M) then
206
               Replace (M, Translate (A, Xlate_U_Und));
207
               Translate (Name, Lower_Case_Map);
208
 
209
            elsif not Match (Name, "Op_", "") then
210
               Translate (Name, Lower_Case_Map);
211
 
212
            else
213
               Name := 'O' & Translate (Name, Lower_Case_Map);
214
            end if;
215
 
216
            if Name = "error" then
217
               Name := V ("<error>");
218
            end if;
219
 
220
            if not Match (Name, Chk_Low) then
221
               Put_Line (OutB, "     """ & Name & "#"" &");
222
            end if;
223
         end if;
224
      end if;
225
   end loop LoopN;
226
 
227
   loop
228
      Line := Get_Line (InB);
229
      exit when Match (Line, "     ""#"";");
230
   end loop;
231
 
232
   Put_Line (OutB, Line);
233
 
234
   while not End_Of_File (InB) loop
235
      Line := Get_Line (InB);
236
      Put_Line (OutB, Line);
237
   end loop;
238
 
239
   Put_Line (OutH, Header_Pending_Line);
240
   while not End_Of_File (InH) loop
241
      Line := Get_Line (InH);
242
      Put_Line (OutH, Line);
243
   end loop;
244
end XSnames;

powered by: WebSVN 2.1.0

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