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