File : a-tigeau.adb


   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-2014, 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 --                                                                          --
  19 --                                                                          --
  20 --                                                                          --
  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       --  Routines calling String_Skip malfunction if Str'Last = Positive'Last.
 447       --  It's too much trouble to make this silly case work, so we just raise
 448       --  Program_Error with an appropriate message. We raise Program_Error
 449       --  rather than Constraint_Error because we don't want this case to be
 450       --  converted to Data_Error.
 451 
 452       if Str'Last = Positive'Last then
 453          raise Program_Error with
 454            "string upper bound is Positive'Last, not supported";
 455       end if;
 456 
 457       --  Normal case where Str'Last < Positive'Last
 458 
 459       Ptr := Str'First;
 460 
 461       loop
 462          if Ptr > Str'Last then
 463             raise End_Error;
 464 
 465          elsif not Is_Blank (Str (Ptr)) then
 466             return;
 467 
 468          else
 469             Ptr := Ptr + 1;
 470          end if;
 471       end loop;
 472    end String_Skip;
 473 
 474    ------------
 475    -- Ungetc --
 476    ------------
 477 
 478    procedure Ungetc (ch : int; File : File_Type) is
 479    begin
 480       if ch /= EOF then
 481          if ungetc (ch, File.Stream) = EOF then
 482             raise Device_Error;
 483          end if;
 484       end if;
 485    end Ungetc;
 486 
 487 end Ada.Text_IO.Generic_Aux;