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