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

Subversion Repositories openrisc

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

Go to most recent revision | 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 . 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.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
   -- Getc --
90
   ----------
91
 
92
   function Getc (File : File_Type) return int is
93
      ch : int;
94
 
95
   begin
96
      ch := fgetc (File.Stream);
97
 
98
      if ch = EOF and then ferror (File.Stream) /= 0 then
99
         raise Device_Error;
100
      else
101
         return ch;
102
      end if;
103
   end Getc;
104
 
105
   --------------
106
   -- Is_Blank --
107
   --------------
108
 
109
   function Is_Blank (C : Character) return Boolean is
110
   begin
111
      return C = ' ' or else C = ASCII.HT;
112
   end Is_Blank;
113
 
114
   ----------
115
   -- Load --
116
   ----------
117
 
118
   procedure Load
119
     (File   : File_Type;
120
      Buf    : out String;
121
      Ptr    : in out Integer;
122
      Char   : Character;
123
      Loaded : out Boolean)
124
   is
125
      ch : int;
126
 
127
   begin
128
      ch := Getc (File);
129
 
130
      if ch = Character'Pos (Char) then
131
         Store_Char (File, ch, Buf, Ptr);
132
         Loaded := True;
133
      else
134
         Ungetc (ch, File);
135
         Loaded := False;
136
      end if;
137
   end Load;
138
 
139
   procedure Load
140
     (File   : File_Type;
141
      Buf    : out String;
142
      Ptr    : in out Integer;
143
      Char   : Character)
144
   is
145
      ch : int;
146
 
147
   begin
148
      ch := Getc (File);
149
 
150
      if ch = Character'Pos (Char) then
151
         Store_Char (File, ch, Buf, Ptr);
152
      else
153
         Ungetc (ch, File);
154
      end if;
155
   end Load;
156
 
157
   procedure Load
158
     (File   : File_Type;
159
      Buf    : out String;
160
      Ptr    : in out Integer;
161
      Char1  : Character;
162
      Char2  : Character;
163
      Loaded : out Boolean)
164
   is
165
      ch : int;
166
 
167
   begin
168
      ch := Getc (File);
169
 
170
      if ch = Character'Pos (Char1) or else ch = Character'Pos (Char2) then
171
         Store_Char (File, ch, Buf, Ptr);
172
         Loaded := True;
173
      else
174
         Ungetc (ch, File);
175
         Loaded := False;
176
      end if;
177
   end Load;
178
 
179
   procedure Load
180
     (File   : File_Type;
181
      Buf    : out String;
182
      Ptr    : in out Integer;
183
      Char1  : Character;
184
      Char2  : Character)
185
   is
186
      ch : int;
187
 
188
   begin
189
      ch := Getc (File);
190
 
191
      if ch = Character'Pos (Char1) or else ch = Character'Pos (Char2) then
192
         Store_Char (File, ch, Buf, Ptr);
193
      else
194
         Ungetc (ch, File);
195
      end if;
196
   end Load;
197
 
198
   -----------------
199
   -- Load_Digits --
200
   -----------------
201
 
202
   procedure Load_Digits
203
     (File   : File_Type;
204
      Buf    : out String;
205
      Ptr    : in out Integer;
206
      Loaded : out Boolean)
207
   is
208
      ch          : int;
209
      After_Digit : Boolean;
210
 
211
   begin
212
      ch := Getc (File);
213
 
214
      if ch not in Character'Pos ('0') .. Character'Pos ('9') then
215
         Loaded := False;
216
 
217
      else
218
         Loaded := True;
219
         After_Digit := True;
220
 
221
         loop
222
            Store_Char (File, ch, Buf, Ptr);
223
            ch := Getc (File);
224
 
225
            if ch in Character'Pos ('0') .. Character'Pos ('9') then
226
               After_Digit := True;
227
 
228
            elsif ch = Character'Pos ('_') and then After_Digit then
229
               After_Digit := False;
230
 
231
            else
232
               exit;
233
            end if;
234
         end loop;
235
      end if;
236
 
237
      Ungetc (ch, File);
238
   end Load_Digits;
239
 
240
   procedure Load_Digits
241
     (File   : File_Type;
242
      Buf    : out String;
243
      Ptr    : in out Integer)
244
   is
245
      ch          : int;
246
      After_Digit : Boolean;
247
 
248
   begin
249
      ch := Getc (File);
250
 
251
      if ch in Character'Pos ('0') .. Character'Pos ('9') then
252
         After_Digit := True;
253
 
254
         loop
255
            Store_Char (File, ch, Buf, Ptr);
256
            ch := Getc (File);
257
 
258
            if ch in Character'Pos ('0') .. Character'Pos ('9') then
259
               After_Digit := True;
260
 
261
            elsif ch = Character'Pos ('_') and then After_Digit then
262
               After_Digit := False;
263
 
264
            else
265
               exit;
266
            end if;
267
         end loop;
268
      end if;
269
 
270
      Ungetc (ch, File);
271
   end Load_Digits;
272
 
273
   --------------------------
274
   -- Load_Extended_Digits --
275
   --------------------------
276
 
277
   procedure Load_Extended_Digits
278
     (File   : File_Type;
279
      Buf    : out String;
280
      Ptr    : in out Integer;
281
      Loaded : out Boolean)
282
   is
283
      ch          : int;
284
      After_Digit : Boolean := False;
285
 
286
   begin
287
      Loaded := False;
288
 
289
      loop
290
         ch := Getc (File);
291
 
292
         if ch in Character'Pos ('0') .. Character'Pos ('9')
293
              or else
294
            ch in Character'Pos ('a') .. Character'Pos ('f')
295
              or else
296
            ch in Character'Pos ('A') .. Character'Pos ('F')
297
         then
298
            After_Digit := True;
299
 
300
         elsif ch = Character'Pos ('_') and then After_Digit then
301
            After_Digit := False;
302
 
303
         else
304
            exit;
305
         end if;
306
 
307
         Store_Char (File, ch, Buf, Ptr);
308
         Loaded := True;
309
      end loop;
310
 
311
      Ungetc (ch, File);
312
   end Load_Extended_Digits;
313
 
314
   procedure Load_Extended_Digits
315
     (File   : File_Type;
316
      Buf    : out String;
317
      Ptr    : in out Integer)
318
   is
319
      Junk : Boolean;
320
      pragma Unreferenced (Junk);
321
   begin
322
      Load_Extended_Digits (File, Buf, Ptr, Junk);
323
   end Load_Extended_Digits;
324
 
325
   ---------------
326
   -- Load_Skip --
327
   ---------------
328
 
329
   procedure Load_Skip (File  : File_Type) is
330
      C : Character;
331
 
332
   begin
333
      FIO.Check_Read_Status (AP (File));
334
 
335
      --  Loop till we find a non-blank character (note that as usual in
336
      --  Text_IO, blank includes horizontal tab). Note that Get deals with
337
      --  the Before_LM and Before_LM_PM flags appropriately.
338
 
339
      loop
340
         Get (File, C);
341
         exit when not Is_Blank (C);
342
      end loop;
343
 
344
      Ungetc (Character'Pos (C), File);
345
      File.Col := File.Col - 1;
346
   end Load_Skip;
347
 
348
   ----------------
349
   -- Load_Width --
350
   ----------------
351
 
352
   procedure Load_Width
353
     (File  : File_Type;
354
      Width : Field;
355
      Buf   : out String;
356
      Ptr   : in out Integer)
357
   is
358
      ch : int;
359
 
360
   begin
361
      FIO.Check_Read_Status (AP (File));
362
 
363
      --  If we are immediately before a line mark, then we have no characters.
364
      --  This is always a data error, so we may as well raise it right away.
365
 
366
      if File.Before_LM then
367
         raise Data_Error;
368
 
369
      else
370
         for J in 1 .. Width loop
371
            ch := Getc (File);
372
 
373
            if ch = EOF then
374
               return;
375
 
376
            elsif ch = LM then
377
               Ungetc (ch, File);
378
               return;
379
 
380
            else
381
               Store_Char (File, ch, Buf, Ptr);
382
            end if;
383
         end loop;
384
      end if;
385
   end Load_Width;
386
 
387
   -----------
388
   -- Nextc --
389
   -----------
390
 
391
   function Nextc (File : File_Type) return int is
392
      ch : int;
393
 
394
   begin
395
      ch := fgetc (File.Stream);
396
 
397
      if ch = EOF then
398
         if ferror (File.Stream) /= 0 then
399
            raise Device_Error;
400
         else
401
            return EOF;
402
         end if;
403
 
404
      else
405
         Ungetc (ch, File);
406
         return ch;
407
      end if;
408
   end Nextc;
409
 
410
   --------------
411
   -- Put_Item --
412
   --------------
413
 
414
   procedure Put_Item (File : File_Type; Str : String) is
415
   begin
416
      Check_On_One_Line (File, Str'Length);
417
      Put (File, Str);
418
   end Put_Item;
419
 
420
   ----------------
421
   -- Store_Char --
422
   ----------------
423
 
424
   procedure Store_Char
425
     (File : File_Type;
426
      ch   : int;
427
      Buf  : in out String;
428
      Ptr  : in out Integer)
429
   is
430
   begin
431
      File.Col := File.Col + 1;
432
 
433
      if Ptr < Buf'Last then
434
         Ptr := Ptr + 1;
435
      end if;
436
 
437
      Buf (Ptr) := Character'Val (ch);
438
   end Store_Char;
439
 
440
   -----------------
441
   -- String_Skip --
442
   -----------------
443
 
444
   procedure String_Skip (Str : String; Ptr : out Integer) is
445
   begin
446
      Ptr := Str'First;
447
 
448
      loop
449
         if Ptr > Str'Last then
450
            raise End_Error;
451
 
452
         elsif not Is_Blank (Str (Ptr)) then
453
            return;
454
 
455
         else
456
            Ptr := Ptr + 1;
457
         end if;
458
      end loop;
459
   end String_Skip;
460
 
461
   ------------
462
   -- Ungetc --
463
   ------------
464
 
465
   procedure Ungetc (ch : int; File : File_Type) is
466
   begin
467
      if ch /= EOF then
468
         if ungetc (ch, File.Stream) = EOF then
469
            raise Device_Error;
470
         end if;
471
      end if;
472
   end Ungetc;
473
 
474
end Ada.Text_IO.Generic_Aux;

powered by: WebSVN 2.1.0

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