gcc/ada/libgnat/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-2017, 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       --  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;