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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

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