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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT RUN-TIME COMPONENTS                         --
4
--                                                                          --
5
--      A D A . W I D E _ T E X T _ I O . E N U M E R A T I O N _ A U X     --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2009, 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.                                     --
17
--                                                                          --
18
-- As a special exception under Section 7 of GPL version 3, you are granted --
19
-- additional permissions described in the GCC Runtime Library Exception,   --
20
-- version 3.1, as published by the Free Software Foundation.               --
21
--                                                                          --
22
-- You should have received a copy of the GNU General Public License and    --
23
-- a copy of the GCC Runtime Library Exception along with this program;     --
24
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25
-- <http://www.gnu.org/licenses/>.                                          --
26
--                                                                          --
27
-- GNAT was originally developed  by the GNAT team at  New York University. --
28
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29
--                                                                          --
30
------------------------------------------------------------------------------
31
 
32
with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux;
33
with Ada.Characters.Handling;      use Ada.Characters.Handling;
34
with Interfaces.C_Streams;         use Interfaces.C_Streams;
35
with System.WCh_Con;               use System.WCh_Con;
36
 
37
package body Ada.Wide_Text_IO.Enumeration_Aux is
38
 
39
   subtype TFT is Ada.Wide_Text_IO.File_Type;
40
   --  File type required for calls to routines in Aux
41
 
42
   -----------------------
43
   -- Local Subprograms --
44
   -----------------------
45
 
46
   procedure Store_Char
47
     (WC  : Wide_Character;
48
      Buf : out Wide_String;
49
      Ptr : in out Integer);
50
   --  Store a single character in buffer, checking for overflow
51
 
52
   --  These definitions replace the ones in Ada.Characters.Handling, which
53
   --  do not seem to work for some strange not understood reason ??? at
54
   --  least in the OS/2 version.
55
 
56
   function To_Lower (C : Character) return Character;
57
 
58
   ------------------
59
   -- Get_Enum_Lit --
60
   ------------------
61
 
62
   procedure Get_Enum_Lit
63
     (File   : File_Type;
64
      Buf    : out Wide_String;
65
      Buflen : out Natural)
66
   is
67
      ch  : int;
68
      WC  : Wide_Character;
69
 
70
   begin
71
      Buflen := 0;
72
      Load_Skip (TFT (File));
73
      ch := Nextc (TFT (File));
74
 
75
      --  Character literal case. If the initial character is a quote, then
76
      --  we read as far as we can without backup (see ACVC test CE3905L)
77
 
78
      if ch = Character'Pos (''') then
79
         Get (File, WC);
80
         Store_Char (WC, Buf, Buflen);
81
 
82
         ch := Nextc (TFT (File));
83
 
84
         if ch = LM or else ch = EOF then
85
            return;
86
         end if;
87
 
88
         Get (File, WC);
89
         Store_Char (WC, Buf, Buflen);
90
 
91
         ch := Nextc (TFT (File));
92
 
93
         if ch /= Character'Pos (''') then
94
            return;
95
         end if;
96
 
97
         Get (File, WC);
98
         Store_Char (WC, Buf, Buflen);
99
 
100
      --  Similarly for identifiers, read as far as we can, in particular,
101
      --  do read a trailing underscore (again see ACVC test CE3905L to
102
      --  understand why we do this, although it seems somewhat peculiar).
103
 
104
      else
105
         --  Identifier must start with a letter. Any wide character value
106
         --  outside the normal Latin-1 range counts as a letter for this.
107
 
108
         if ch < 255 and then not Is_Letter (Character'Val (ch)) then
109
            return;
110
         end if;
111
 
112
         --  If we do have a letter, loop through the characters quitting on
113
         --  the first non-identifier character (note that this includes the
114
         --  cases of hitting a line mark or page mark).
115
 
116
         loop
117
            Get (File, WC);
118
            Store_Char (WC, Buf, Buflen);
119
 
120
            ch := Nextc (TFT (File));
121
 
122
            exit when ch = EOF;
123
 
124
            if ch = Character'Pos ('_') then
125
               exit when Buf (Buflen) = '_';
126
 
127
            elsif ch = Character'Pos (ASCII.ESC) then
128
               null;
129
 
130
            elsif File.WC_Method in WC_Upper_Half_Encoding_Method
131
              and then ch > 127
132
            then
133
               null;
134
 
135
            else
136
               exit when not Is_Letter (Character'Val (ch))
137
                           and then
138
                         not Is_Digit (Character'Val (ch));
139
            end if;
140
         end loop;
141
      end if;
142
   end Get_Enum_Lit;
143
 
144
   ---------
145
   -- Put --
146
   ---------
147
 
148
   procedure Put
149
     (File  : File_Type;
150
      Item  : Wide_String;
151
      Width : Field;
152
      Set   : Type_Set)
153
   is
154
      Actual_Width : constant Integer :=
155
                       Integer'Max (Integer (Width), Item'Length);
156
 
157
   begin
158
      Check_On_One_Line (TFT (File), Actual_Width);
159
 
160
      if Set = Lower_Case and then Item (Item'First) /= ''' then
161
         declare
162
            Iteml : Wide_String (Item'First .. Item'Last);
163
 
164
         begin
165
            for J in Item'Range loop
166
               if Is_Character (Item (J)) then
167
                  Iteml (J) :=
168
                    To_Wide_Character (To_Lower (To_Character (Item (J))));
169
               else
170
                  Iteml (J) := Item (J);
171
               end if;
172
            end loop;
173
 
174
            Put (File, Iteml);
175
         end;
176
 
177
      else
178
         Put (File, Item);
179
      end if;
180
 
181
      for J in 1 .. Actual_Width - Item'Length loop
182
         Put (File, ' ');
183
      end loop;
184
   end Put;
185
 
186
   ----------
187
   -- Puts --
188
   ----------
189
 
190
   procedure Puts
191
     (To   : out Wide_String;
192
      Item : Wide_String;
193
      Set  : Type_Set)
194
   is
195
      Ptr : Natural;
196
 
197
   begin
198
      if Item'Length > To'Length then
199
         raise Layout_Error;
200
 
201
      else
202
         Ptr := To'First;
203
         for J in Item'Range loop
204
            if Set = Lower_Case
205
              and then Item (Item'First) /= '''
206
              and then Is_Character (Item (J))
207
            then
208
               To (Ptr) :=
209
                 To_Wide_Character (To_Lower (To_Character (Item (J))));
210
            else
211
               To (Ptr) := Item (J);
212
            end if;
213
 
214
            Ptr := Ptr + 1;
215
         end loop;
216
 
217
         while Ptr <= To'Last loop
218
            To (Ptr) := ' ';
219
            Ptr := Ptr + 1;
220
         end loop;
221
      end if;
222
   end Puts;
223
 
224
   -------------------
225
   -- Scan_Enum_Lit --
226
   -------------------
227
 
228
   procedure Scan_Enum_Lit
229
     (From  : Wide_String;
230
      Start : out Natural;
231
      Stop  : out Natural)
232
   is
233
      WC  : Wide_Character;
234
 
235
   --  Processing for Scan_Enum_Lit
236
 
237
   begin
238
      Start := From'First;
239
 
240
      loop
241
         if Start > From'Last then
242
            raise End_Error;
243
 
244
         elsif Is_Character (From (Start))
245
           and then not Is_Blank (To_Character (From (Start)))
246
         then
247
            exit;
248
 
249
         else
250
            Start := Start + 1;
251
         end if;
252
      end loop;
253
 
254
      --  Character literal case. If the initial character is a quote, then
255
      --  we read as far as we can without backup (see ACVC test CE3905L
256
      --  which is for the analogous case for reading from a file).
257
 
258
      if From (Start) = ''' then
259
         Stop := Start;
260
 
261
         if Stop = From'Last then
262
            raise Data_Error;
263
         else
264
            Stop := Stop + 1;
265
         end if;
266
 
267
         if From (Stop) in ' ' .. '~'
268
           or else From (Stop) >= Wide_Character'Val (16#80#)
269
         then
270
            if Stop = From'Last then
271
               raise Data_Error;
272
            else
273
               Stop := Stop + 1;
274
 
275
               if From (Stop) = ''' then
276
                  return;
277
               end if;
278
            end if;
279
         end if;
280
 
281
         raise Data_Error;
282
 
283
      --  Similarly for identifiers, read as far as we can, in particular,
284
      --  do read a trailing underscore (again see ACVC test CE3905L to
285
      --  understand why we do this, although it seems somewhat peculiar).
286
 
287
      else
288
         --  Identifier must start with a letter, any wide character outside
289
         --  the normal Latin-1 range is considered a letter for this test.
290
 
291
         if Is_Character (From (Start))
292
           and then not Is_Letter (To_Character (From (Start)))
293
         then
294
            raise Data_Error;
295
         end if;
296
 
297
         --  If we do have a letter, loop through the characters quitting on
298
         --  the first non-identifier character (note that this includes the
299
         --  cases of hitting a line mark or page mark).
300
 
301
         Stop := Start + 1;
302
         while Stop < From'Last loop
303
            WC := From (Stop + 1);
304
 
305
            exit when
306
              Is_Character (WC)
307
                and then
308
                  not Is_Letter (To_Character (WC))
309
                and then
310
                  not Is_Letter (To_Character (WC))
311
                and then
312
                  (WC /= '_' or else From (Stop - 1) = '_');
313
 
314
            Stop := Stop + 1;
315
         end loop;
316
      end if;
317
 
318
   end Scan_Enum_Lit;
319
 
320
   ----------------
321
   -- Store_Char --
322
   ----------------
323
 
324
   procedure Store_Char
325
     (WC  : Wide_Character;
326
      Buf : out Wide_String;
327
      Ptr : in out Integer)
328
   is
329
   begin
330
      if Ptr = Buf'Last then
331
         raise Data_Error;
332
      else
333
         Ptr := Ptr + 1;
334
         Buf (Ptr) := WC;
335
      end if;
336
   end Store_Char;
337
 
338
   --------------
339
   -- To_Lower --
340
   --------------
341
 
342
   function To_Lower (C : Character) return Character is
343
   begin
344
      if C in 'A' .. 'Z' then
345
         return Character'Val (Character'Pos (C) + 32);
346
      else
347
         return C;
348
      end if;
349
   end To_Lower;
350
 
351
end Ada.Wide_Text_IO.Enumeration_Aux;

powered by: WebSVN 2.1.0

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