gcc/ada/a-tigeau.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUNTIME 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 --                                                                          --
  10 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNAT was originally developed  by the GNAT team at  New York University. --
  31 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 with Interfaces.C_Streams; use Interfaces.C_Streams;
  36 with System.File_IO;
  37 with System.File_Control_Block;
  38
  39 package body Ada.Text_IO.Generic_Aux is
  40
  41    package FIO renames System.File_IO;
  42    package FCB renames System.File_Control_Block;
  43    subtype AP is FCB.AFCB_Ptr;
  44
  45    ------------------------
  46    -- Check_End_Of_Field --
  47    ------------------------
  48
  49    procedure Check_End_Of_Field
  50      (Buf   : String;
  51       Stop  : Integer;
  52       Ptr   : Integer;
  53       Width : Field)
  54    is
  55    begin
  56       if Ptr > Stop then
  57          return;
  58
  59       elsif Width = 0 then
  60          raise Data_Error;
  61
  62       else
  63          for J in Ptr .. Stop loop
  64             if not Is_Blank (Buf (J)) then
  65                raise Data_Error;
  66             end if;
  67          end loop;
  68       end if;
  69    end Check_End_Of_Field;
  70
  71    -----------------------
  72    -- Check_On_One_Line --
  73    -----------------------
  74
  75    procedure Check_On_One_Line
  76      (File   : File_Type;
  77       Length : Integer)
  78    is
  79    begin
  80       FIO.Check_Write_Status (AP (File));
  81
  82       if File.Line_Length /= 0 then
  83          if Count (Length) > File.Line_Length then
  84             raise Layout_Error;
  85          elsif File.Col + Count (Length) > File.Line_Length + 1 then
  86             New_Line (File);
  87          end if;
  88       end if;
  89    end Check_On_One_Line;
  90
  91    ----------
  92    -- Getc --
  93    ----------
  94
  95    function Getc (File : File_Type) return int is
  96       ch : int;
  97
  98    begin
  99       ch := fgetc (File.Stream);
 100
 101       if ch = EOF and then ferror (File.Stream) /= 0 then
 102          raise Device_Error;
 103       else
 104          return ch;
 105       end if;
 106    end Getc;
 107
 108    --------------
 109    -- Is_Blank --
 110    --------------
 111
 112    function Is_Blank (C : Character) return Boolean is
 113    begin
 114       return C = ' ' or else C = ASCII.HT;
 115    end Is_Blank;
 116
 117    ----------
 118    -- Load --
 119    ----------
 120
 121    procedure Load
 122      (File   : File_Type;
 123       Buf    : out String;
 124       Ptr    : in out Integer;
 125       Char   : Character;
 126       Loaded : out Boolean)
 127    is
 128       ch : int;
 129
 130    begin
 131       ch := Getc (File);
 132
 133       if ch = Character'Pos (Char) then
 134          Store_Char (File, ch, Buf, Ptr);
 135          Loaded := True;
 136       else
 137          Ungetc (ch, File);
 138          Loaded := False;
 139       end if;
 140    end Load;
 141
 142    procedure Load
 143      (File   : File_Type;
 144       Buf    : out String;
 145       Ptr    : in out Integer;
 146       Char   : Character)
 147    is
 148       ch : int;
 149
 150    begin
 151       ch := Getc (File);
 152
 153       if ch = Character'Pos (Char) then
 154          Store_Char (File, ch, Buf, Ptr);
 155       else
 156          Ungetc (ch, File);
 157       end if;
 158    end Load;
 159
 160    procedure Load
 161      (File   : File_Type;
 162       Buf    : out String;
 163       Ptr    : in out Integer;
 164       Char1  : Character;
 165       Char2  : Character;
 166       Loaded : out Boolean)
 167    is
 168       ch : int;
 169
 170    begin
 171       ch := Getc (File);
 172
 173       if ch = Character'Pos (Char1) or else ch = Character'Pos (Char2) then
 174          Store_Char (File, ch, Buf, Ptr);
 175          Loaded := True;
 176       else
 177          Ungetc (ch, File);
 178          Loaded := False;
 179       end if;
 180    end Load;
 181
 182    procedure Load
 183      (File   : File_Type;
 184       Buf    : out String;
 185       Ptr    : in out Integer;
 186       Char1  : Character;
 187       Char2  : Character)
 188    is
 189       ch : int;
 190
 191    begin
 192       ch := Getc (File);
 193
 194       if ch = Character'Pos (Char1) or else ch = Character'Pos (Char2) then
 195          Store_Char (File, ch, Buf, Ptr);
 196       else
 197          Ungetc (ch, File);
 198       end if;
 199    end Load;
 200
 201    -----------------
 202    -- Load_Digits --
 203    -----------------
 204
 205    procedure Load_Digits
 206      (File   : File_Type;
 207       Buf    : out String;
 208       Ptr    : in out Integer;
 209       Loaded : out Boolean)
 210    is
 211       ch          : int;
 212       After_Digit : Boolean;
 213
 214    begin
 215       ch := Getc (File);
 216
 217       if ch not in Character'Pos ('0') .. Character'Pos ('9') then
 218          Loaded := False;
 219
 220       else
 221          Loaded := True;
 222          After_Digit := True;
 223
 224          loop
 225             Store_Char (File, ch, Buf, Ptr);
 226             ch := Getc (File);
 227
 228             if ch in Character'Pos ('0') .. Character'Pos ('9') then
 229                After_Digit := True;
 230
 231             elsif ch = Character'Pos ('_') and then After_Digit then
 232                After_Digit := False;
 233
 234             else
 235                exit;
 236             end if;
 237          end loop;
 238       end if;
 239
 240       Ungetc (ch, File);
 241    end Load_Digits;
 242
 243    procedure Load_Digits
 244      (File   : File_Type;
 245       Buf    : out String;
 246       Ptr    : in out Integer)
 247    is
 248       ch          : int;
 249       After_Digit : Boolean;
 250
 251    begin
 252       ch := Getc (File);
 253
 254       if ch in Character'Pos ('0') .. Character'Pos ('9') then
 255          After_Digit := True;
 256
 257          loop
 258             Store_Char (File, ch, Buf, Ptr);
 259             ch := Getc (File);
 260
 261             if ch in Character'Pos ('0') .. Character'Pos ('9') then
 262                After_Digit := True;
 263
 264             elsif ch = Character'Pos ('_') and then After_Digit then
 265                After_Digit := False;
 266
 267             else
 268                exit;
 269             end if;
 270          end loop;
 271       end if;
 272
 273       Ungetc (ch, File);
 274    end Load_Digits;
 275
 276    --------------------------
 277    -- Load_Extended_Digits --
 278    --------------------------
 279
 280    procedure Load_Extended_Digits
 281      (File   : File_Type;
 282       Buf    : out String;
 283       Ptr    : in out Integer;
 284       Loaded : out Boolean)
 285    is
 286       ch          : int;
 287       After_Digit : Boolean := False;
 288
 289    begin
 290       Loaded := False;
 291
 292       loop
 293          ch := Getc (File);
 294
 295          if ch in Character'Pos ('0') .. Character'Pos ('9')
 296               or else
 297             ch in Character'Pos ('a') .. Character'Pos ('f')
 298               or else
 299             ch in Character'Pos ('A') .. Character'Pos ('F')
 300          then
 301             After_Digit := True;
 302
 303          elsif ch = Character'Pos ('_') and then After_Digit then
 304             After_Digit := False;
 305
 306          else
 307             exit;
 308          end if;
 309
 310          Store_Char (File, ch, Buf, Ptr);
 311          Loaded := True;
 312       end loop;
 313
 314       Ungetc (ch, File);
 315    end Load_Extended_Digits;
 316
 317    procedure Load_Extended_Digits
 318      (File   : File_Type;
 319       Buf    : out String;
 320       Ptr    : in out Integer)
 321    is
 322       Junk : Boolean;
 323
 324    begin
 325       Load_Extended_Digits (File, Buf, Ptr, Junk);
 326    end Load_Extended_Digits;
 327
 328    ---------------
 329    -- Load_Skip --
 330    ---------------
 331
 332    procedure Load_Skip (File  : File_Type) is
 333       C : Character;
 334
 335    begin
 336       FIO.Check_Read_Status (AP (File));
 337
 338       --  Loop till we find a non-blank character (note that as usual in
 339       --  Text_IO, blank includes horizontal tab). Note that Get deals with
 340       --  the Before_LM and Before_LM_PM flags appropriately.
 341
 342       loop
 343          Get (File, C);
 344          exit when not Is_Blank (C);
 345       end loop;
 346
 347       Ungetc (Character'Pos (C), File);
 348       File.Col := File.Col - 1;
 349    end Load_Skip;
 350
 351    ----------------
 352    -- Load_Width --
 353    ----------------
 354
 355    procedure Load_Width
 356      (File  : File_Type;
 357       Width : Field;
 358       Buf   : out String;
 359       Ptr   : in out Integer)
 360    is
 361       ch : int;
 362
 363    begin
 364       FIO.Check_Read_Status (AP (File));
 365
 366       --  If we are immediately before a line mark, then we have no characters.
 367       --  This is always a data error, so we may as well raise it right away.
 368
 369       if File.Before_LM then
 370          raise Data_Error;
 371
 372       else
 373          for J in 1 .. Width loop
 374             ch := Getc (File);
 375
 376             if ch = EOF then
 377                return;
 378
 379             elsif ch = LM then
 380                Ungetc (ch, File);
 381                return;
 382
 383             else
 384                Store_Char (File, ch, Buf, Ptr);
 385             end if;
 386          end loop;
 387       end if;
 388    end Load_Width;
 389
 390    -----------
 391    -- Nextc --
 392    -----------
 393
 394    function Nextc (File : File_Type) return int is
 395       ch : int;
 396
 397    begin
 398       ch := fgetc (File.Stream);
 399
 400       if ch = EOF then
 401          if ferror (File.Stream) /= 0 then
 402             raise Device_Error;
 403          else
 404             return EOF;
 405          end if;
 406
 407       else
 408          Ungetc (ch, File);
 409          return ch;
 410       end if;
 411    end Nextc;
 412
 413    --------------
 414    -- Put_Item --
 415    --------------
 416
 417    procedure Put_Item (File : File_Type; Str : String) is
 418    begin
 419       Check_On_One_Line (File, Str'Length);
 420       Put (File, Str);
 421    end Put_Item;
 422
 423    ----------------
 424    -- Store_Char --
 425    ----------------
 426
 427    procedure Store_Char
 428      (File : File_Type;
 429       ch   : int;
 430       Buf  : out String;
 431       Ptr  : in out Integer)
 432    is
 433    begin
 434       File.Col := File.Col + 1;
 435
 436       if Ptr = Buf'Last then
 437          raise Data_Error;
 438       else
 439          Ptr := Ptr + 1;
 440          Buf (Ptr) := Character'Val (ch);
 441       end if;
 442    end Store_Char;
 443
 444    -----------------
 445    -- String_Skip --
 446    -----------------
 447
 448    procedure String_Skip (Str : String; Ptr : out Integer) is
 449    begin
 450       Ptr := Str'First;
 451
 452       loop
 453          if Ptr > Str'Last then
 454             raise End_Error;
 455
 456          elsif not Is_Blank (Str (Ptr)) then
 457             return;
 458
 459          else
 460             Ptr := Ptr + 1;
 461          end if;
 462       end loop;
 463    end String_Skip;
 464
 465    ------------
 466    -- Ungetc --
 467    ------------
 468
 469    procedure Ungetc (ch : int; File : File_Type) is
 470    begin
 471       if ch /= EOF then
 472          if ungetc (ch, File.Stream) = EOF then
 473             raise Device_Error;
 474          end if;
 475       end if;
 476    end Ungetc;
 477
 478 end Ada.Text_IO.Generic_Aux;