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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-wtgeau.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
--         A D A . W I D E _ T E X T _ I O . G E N E R I C _ 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 Interfaces.C_Streams; use Interfaces.C_Streams;
33
with System.File_IO;
34
with System.File_Control_Block;
35
 
36
package body Ada.Wide_Text_IO.Generic_Aux is
37
 
38
   package FIO renames System.File_IO;
39
   package FCB renames System.File_Control_Block;
40
   subtype AP is FCB.AFCB_Ptr;
41
 
42
   ------------------------
43
   -- Check_End_Of_Field --
44
   ------------------------
45
 
46
   procedure Check_End_Of_Field
47
     (Buf   : String;
48
      Stop  : Integer;
49
      Ptr   : Integer;
50
      Width : Field)
51
   is
52
   begin
53
      if Ptr > Stop then
54
         return;
55
 
56
      elsif Width = 0 then
57
         raise Data_Error;
58
 
59
      else
60
         for J in Ptr .. Stop loop
61
            if not Is_Blank (Buf (J)) then
62
               raise Data_Error;
63
            end if;
64
         end loop;
65
      end if;
66
   end Check_End_Of_Field;
67
 
68
   -----------------------
69
   -- Check_On_One_Line --
70
   -----------------------
71
 
72
   procedure Check_On_One_Line
73
     (File   : File_Type;
74
      Length : Integer)
75
   is
76
   begin
77
      FIO.Check_Write_Status (AP (File));
78
 
79
      if File.Line_Length /= 0 then
80
         if Count (Length) > File.Line_Length then
81
            raise Layout_Error;
82
         elsif File.Col + Count (Length) > File.Line_Length + 1 then
83
            New_Line (File);
84
         end if;
85
      end if;
86
   end Check_On_One_Line;
87
 
88
   --------------
89
   -- Is_Blank --
90
   --------------
91
 
92
   function Is_Blank (C : Character) return Boolean is
93
   begin
94
      return C = ' ' or else C = ASCII.HT;
95
   end Is_Blank;
96
 
97
   ----------
98
   -- Load --
99
   ----------
100
 
101
   procedure Load
102
     (File   : File_Type;
103
      Buf    : out String;
104
      Ptr    : in out Integer;
105
      Char   : Character;
106
      Loaded : out Boolean)
107
   is
108
      ch : int;
109
 
110
   begin
111
      if File.Before_Wide_Character then
112
         Loaded := False;
113
         return;
114
 
115
      else
116
         ch := Getc (File);
117
 
118
         if ch = Character'Pos (Char) then
119
            Store_Char (File, ch, Buf, Ptr);
120
            Loaded := True;
121
         else
122
            Ungetc (ch, File);
123
            Loaded := False;
124
         end if;
125
      end if;
126
   end Load;
127
 
128
   procedure Load
129
     (File   : File_Type;
130
      Buf    : out String;
131
      Ptr    : in out Integer;
132
      Char   : Character)
133
   is
134
      ch : int;
135
 
136
   begin
137
      if File.Before_Wide_Character then
138
         null;
139
 
140
      else
141
         ch := Getc (File);
142
 
143
         if ch = Character'Pos (Char) then
144
            Store_Char (File, ch, Buf, Ptr);
145
         else
146
            Ungetc (ch, File);
147
         end if;
148
      end if;
149
   end Load;
150
 
151
   procedure Load
152
     (File   : File_Type;
153
      Buf    : out String;
154
      Ptr    : in out Integer;
155
      Char1  : Character;
156
      Char2  : Character;
157
      Loaded : out Boolean)
158
   is
159
      ch : int;
160
 
161
   begin
162
      if File.Before_Wide_Character then
163
         Loaded := False;
164
         return;
165
 
166
      else
167
         ch := Getc (File);
168
 
169
         if ch = Character'Pos (Char1)
170
           or else ch = Character'Pos (Char2)
171
         then
172
            Store_Char (File, ch, Buf, Ptr);
173
            Loaded := True;
174
         else
175
            Ungetc (ch, File);
176
            Loaded := False;
177
         end if;
178
      end if;
179
   end Load;
180
 
181
   procedure Load
182
     (File   : File_Type;
183
      Buf    : out String;
184
      Ptr    : in out Integer;
185
      Char1  : Character;
186
      Char2  : Character)
187
   is
188
      ch : int;
189
 
190
   begin
191
      if File.Before_Wide_Character then
192
         null;
193
 
194
      else
195
         ch := Getc (File);
196
 
197
         if ch = Character'Pos (Char1)
198
           or else ch = Character'Pos (Char2)
199
         then
200
            Store_Char (File, ch, Buf, Ptr);
201
         else
202
            Ungetc (ch, File);
203
         end if;
204
      end if;
205
   end Load;
206
 
207
   -----------------
208
   -- Load_Digits --
209
   -----------------
210
 
211
   procedure Load_Digits
212
     (File   : File_Type;
213
      Buf    : out String;
214
      Ptr    : in out Integer;
215
      Loaded : out Boolean)
216
   is
217
      ch          : int;
218
      After_Digit : Boolean;
219
 
220
   begin
221
      if File.Before_Wide_Character then
222
         Loaded := False;
223
         return;
224
 
225
      else
226
         ch := Getc (File);
227
 
228
         if ch not in Character'Pos ('0') .. Character'Pos ('9') then
229
            Loaded := False;
230
 
231
         else
232
            Loaded := True;
233
            After_Digit := True;
234
 
235
            loop
236
               Store_Char (File, ch, Buf, Ptr);
237
               ch := Getc (File);
238
 
239
               if ch in Character'Pos ('0') .. Character'Pos ('9') then
240
                  After_Digit := True;
241
 
242
               elsif ch = Character'Pos ('_') and then After_Digit then
243
                  After_Digit := False;
244
 
245
               else
246
                  exit;
247
               end if;
248
            end loop;
249
         end if;
250
 
251
         Ungetc (ch, File);
252
      end if;
253
   end Load_Digits;
254
 
255
   procedure Load_Digits
256
     (File   : File_Type;
257
      Buf    : out String;
258
      Ptr    : in out Integer)
259
   is
260
      ch          : int;
261
      After_Digit : Boolean;
262
 
263
   begin
264
      if File.Before_Wide_Character then
265
         return;
266
 
267
      else
268
         ch := Getc (File);
269
 
270
         if ch in Character'Pos ('0') .. Character'Pos ('9') then
271
            After_Digit := True;
272
 
273
            loop
274
               Store_Char (File, ch, Buf, Ptr);
275
               ch := Getc (File);
276
 
277
               if ch in Character'Pos ('0') .. Character'Pos ('9') then
278
                  After_Digit := True;
279
 
280
               elsif ch = Character'Pos ('_') and then After_Digit then
281
                  After_Digit := False;
282
 
283
               else
284
                  exit;
285
               end if;
286
            end loop;
287
         end if;
288
 
289
         Ungetc (ch, File);
290
      end if;
291
   end Load_Digits;
292
 
293
   --------------------------
294
   -- Load_Extended_Digits --
295
   --------------------------
296
 
297
   procedure Load_Extended_Digits
298
     (File   : File_Type;
299
      Buf    : out String;
300
      Ptr    : in out Integer;
301
      Loaded : out Boolean)
302
   is
303
      ch          : int;
304
      After_Digit : Boolean := False;
305
 
306
   begin
307
      if File.Before_Wide_Character then
308
         Loaded := False;
309
         return;
310
 
311
      else
312
         Loaded := False;
313
 
314
         loop
315
            ch := Getc (File);
316
 
317
            if ch in Character'Pos ('0') .. Character'Pos ('9')
318
                 or else
319
               ch in Character'Pos ('a') .. Character'Pos ('f')
320
                 or else
321
               ch in Character'Pos ('A') .. Character'Pos ('F')
322
            then
323
               After_Digit := True;
324
 
325
            elsif ch = Character'Pos ('_') and then After_Digit then
326
               After_Digit := False;
327
 
328
            else
329
               exit;
330
            end if;
331
 
332
            Store_Char (File, ch, Buf, Ptr);
333
            Loaded := True;
334
         end loop;
335
 
336
         Ungetc (ch, File);
337
      end if;
338
   end Load_Extended_Digits;
339
 
340
   procedure Load_Extended_Digits
341
     (File   : File_Type;
342
      Buf    : out String;
343
      Ptr    : in out Integer)
344
   is
345
      Junk : Boolean;
346
      pragma Unreferenced (Junk);
347
   begin
348
      Load_Extended_Digits (File, Buf, Ptr, Junk);
349
   end Load_Extended_Digits;
350
 
351
   ---------------
352
   -- Load_Skip --
353
   ---------------
354
 
355
   procedure Load_Skip (File  : File_Type) is
356
      C : Character;
357
 
358
   begin
359
      FIO.Check_Read_Status (AP (File));
360
 
361
      --  We need to explicitly test for the case of being before a wide
362
      --  character (greater than 16#7F#). Since no such character can
363
      --  ever legitimately be a valid numeric character, we can
364
      --  immediately signal Data_Error.
365
 
366
      if File.Before_Wide_Character then
367
         raise Data_Error;
368
      end if;
369
 
370
      --  Otherwise loop till we find a non-blank character (note that as
371
      --  usual in Wide_Text_IO, blank includes horizontal tab). Note that
372
      --  Get_Character deals with Before_LM/Before_LM_PM flags appropriately.
373
 
374
      loop
375
         Get_Character (File, C);
376
         exit when not Is_Blank (C);
377
      end loop;
378
 
379
      Ungetc (Character'Pos (C), File);
380
      File.Col := File.Col - 1;
381
   end Load_Skip;
382
 
383
   ----------------
384
   -- Load_Width --
385
   ----------------
386
 
387
   procedure Load_Width
388
     (File  : File_Type;
389
      Width : Field;
390
      Buf   : out String;
391
      Ptr   : in out Integer)
392
   is
393
      ch : int;
394
      WC : Wide_Character;
395
 
396
      Bad_Wide_C : Boolean := False;
397
      --  Set True if one of the characters read is not in range of type
398
      --  Character. This is always a Data_Error, but we do not signal it
399
      --  right away, since we have to read the full number of characters.
400
 
401
   begin
402
      FIO.Check_Read_Status (AP (File));
403
 
404
      --  If we are immediately before a line mark, then we have no characters.
405
      --  This is always a data error, so we may as well raise it right away.
406
 
407
      if File.Before_LM then
408
         raise Data_Error;
409
 
410
      else
411
         for J in 1 .. Width loop
412
            if File.Before_Wide_Character then
413
               Bad_Wide_C := True;
414
               Store_Char (File, 0, Buf, Ptr);
415
               File.Before_Wide_Character := False;
416
 
417
            else
418
               ch := Getc (File);
419
 
420
               if ch = EOF then
421
                  exit;
422
 
423
               elsif ch = LM then
424
                  Ungetc (ch, File);
425
                  exit;
426
 
427
               else
428
                  WC := Get_Wide_Char (Character'Val (ch), File);
429
                  ch := Wide_Character'Pos (WC);
430
 
431
                  if ch > 255 then
432
                     Bad_Wide_C := True;
433
                     ch := 0;
434
                  end if;
435
 
436
                  Store_Char (File, ch, Buf, Ptr);
437
               end if;
438
            end if;
439
         end loop;
440
 
441
         if Bad_Wide_C then
442
            raise Data_Error;
443
         end if;
444
      end if;
445
   end Load_Width;
446
 
447
   --------------
448
   -- Put_Item --
449
   --------------
450
 
451
   procedure Put_Item (File : File_Type; Str : String) is
452
   begin
453
      Check_On_One_Line (File, Str'Length);
454
 
455
      for J in Str'Range loop
456
         Put (File, Wide_Character'Val (Character'Pos (Str (J))));
457
      end loop;
458
   end Put_Item;
459
 
460
   ----------------
461
   -- Store_Char --
462
   ----------------
463
 
464
   procedure Store_Char
465
     (File : File_Type;
466
      ch   : Integer;
467
      Buf  : out String;
468
      Ptr  : in out Integer)
469
   is
470
   begin
471
      File.Col := File.Col + 1;
472
 
473
      if Ptr = Buf'Last then
474
         raise Data_Error;
475
      else
476
         Ptr := Ptr + 1;
477
         Buf (Ptr) := Character'Val (ch);
478
      end if;
479
   end Store_Char;
480
 
481
   -----------------
482
   -- String_Skip --
483
   -----------------
484
 
485
   procedure String_Skip (Str : String; Ptr : out Integer) is
486
   begin
487
      Ptr := Str'First;
488
 
489
      loop
490
         if Ptr > Str'Last then
491
            raise End_Error;
492
 
493
         elsif not Is_Blank (Str (Ptr)) then
494
            return;
495
 
496
         else
497
            Ptr := Ptr + 1;
498
         end if;
499
      end loop;
500
   end String_Skip;
501
 
502
   ------------
503
   -- Ungetc --
504
   ------------
505
 
506
   procedure Ungetc (ch : int; File : File_Type) is
507
   begin
508
      if ch /= EOF then
509
         if ungetc (ch, File.Stream) = EOF then
510
            raise Device_Error;
511
         end if;
512
      end if;
513
   end Ungetc;
514
 
515
end Ada.Wide_Text_IO.Generic_Aux;

powered by: WebSVN 2.1.0

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