1------------------------------------------------------------------------------
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
32with Interfaces.C_Streams; use Interfaces.C_Streams;
33with System.File_IO;
34with System.File_Control_Block;
35
36package 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
474end Ada.Text_IO.Generic_Aux;
475