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