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-2024, 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    begin
 321       Load_Extended_Digits (File, Buf, Ptr, Junk);
 322    end Load_Extended_Digits;
 323
 324    ------------------
 325    -- Load_Integer --
 326    ------------------
 327
 328    procedure Load_Integer
 329      (File : File_Type;
 330       Buf  : out String;
 331       Ptr  : in out Natural)
 332    is
 333       Hash_Loc : Natural;
 334       Loaded   : Boolean;
 335
 336    begin
 337       Load_Skip (File);
 338
 339       --  Note: it is a bit strange to allow a minus sign here, but it seems
 340       --  consistent with the general behavior expected by the ACVC tests
 341       --  which is to scan past junk and then signal data error, see ACVC
 342       --  test CE3704F, case (6), which is for signed integer exponents,
 343       --  which seems a similar case.
 344
 345       Load (File, Buf, Ptr, '+', '-');
 346       Load_Digits (File, Buf, Ptr, Loaded);
 347
 348       if Loaded then
 349
 350          --  Deal with based literal. We recognize either the standard '#' or
 351          --  the allowed alternative replacement ':' (see RM J.2(3)).
 352
 353          Load (File, Buf, Ptr, '#', ':', Loaded);
 354
 355          if Loaded then
 356             Hash_Loc := Ptr;
 357             Load_Extended_Digits (File, Buf, Ptr);
 358             Load (File, Buf, Ptr, Buf (Hash_Loc));
 359          end if;
 360
 361          --  Deal with exponent
 362
 363          Load (File, Buf, Ptr, 'E', 'e', Loaded);
 364
 365          if Loaded then
 366
 367             --  Note: it is strange to allow a minus sign, since the syntax
 368             --  does not, but that is what ACVC test CE3704F, case (6) wants
 369             --  for the signed case, and there seems no good reason to treat
 370             --  exponents differently for the signed and unsigned cases.
 371
 372             Load (File, Buf, Ptr, '+', '-');
 373             Load_Digits (File, Buf, Ptr);
 374          end if;
 375       end if;
 376    end Load_Integer;
 377
 378    ---------------
 379    -- Load_Real --
 380    ---------------
 381
 382    procedure Load_Real
 383      (File : File_Type;
 384       Buf  : out String;
 385       Ptr  : in out Natural)
 386    is
 387       Loaded : Boolean;
 388
 389    begin
 390       --  Skip initial blanks, and load possible sign
 391
 392       Load_Skip (File);
 393       Load (File, Buf, Ptr, '+', '-');
 394
 395       --  Case of .nnnn
 396
 397       Load (File, Buf, Ptr, '.', Loaded);
 398
 399       if Loaded then
 400          Load_Digits (File, Buf, Ptr, Loaded);
 401
 402          --  Hopeless junk if no digits loaded
 403
 404          if not Loaded then
 405             return;
 406          end if;
 407
 408       --  Otherwise must have digits to start
 409
 410       else
 411          Load_Digits (File, Buf, Ptr, Loaded);
 412
 413          --  Hopeless junk if no digits loaded
 414
 415          if not Loaded then
 416             return;
 417          end if;
 418
 419          --  Based cases. We recognize either the standard '#' or the
 420          --  allowed alternative replacement ':' (see RM J.2(3)).
 421
 422          Load (File, Buf, Ptr, '#', ':', Loaded);
 423
 424          if Loaded then
 425
 426             --  Case of nnn#.xxx#
 427
 428             Load (File, Buf, Ptr, '.', Loaded);
 429
 430             if Loaded then
 431                Load_Extended_Digits (File, Buf, Ptr);
 432                Load (File, Buf, Ptr, '#', ':');
 433
 434             --  Case of nnn#xxx.[xxx]# or nnn#xxx#
 435
 436             else
 437                Load_Extended_Digits (File, Buf, Ptr);
 438                Load (File, Buf, Ptr, '.', Loaded);
 439
 440                if Loaded then
 441                   Load_Extended_Digits (File, Buf, Ptr);
 442                end if;
 443
 444                --  As usual, it seems strange to allow mixed base characters,
 445                --  but that is what ACVC tests expect, see CE3804M, case (3).
 446
 447                Load (File, Buf, Ptr, '#', ':');
 448             end if;
 449
 450          --  Case of nnn.[nnn] or nnn
 451
 452          else
 453             --  Prevent the potential processing of '.' in cases where the
 454             --  initial digits have a trailing underscore.
 455
 456             if Buf (Ptr) = '_' then
 457                return;
 458             end if;
 459
 460             Load (File, Buf, Ptr, '.', Loaded);
 461
 462             if Loaded then
 463                Load_Digits (File, Buf, Ptr);
 464             end if;
 465          end if;
 466       end if;
 467
 468       --  Deal with exponent
 469
 470       Load (File, Buf, Ptr, 'E', 'e', Loaded);
 471
 472       if Loaded then
 473          Load (File, Buf, Ptr, '+', '-');
 474          Load_Digits (File, Buf, Ptr);
 475       end if;
 476    end Load_Real;
 477
 478    ---------------
 479    -- Load_Skip --
 480    ---------------
 481
 482    procedure Load_Skip (File  : File_Type) is
 483       C : Character;
 484
 485    begin
 486       FIO.Check_Read_Status (AP (File));
 487
 488       --  Loop till we find a non-blank character (note that as usual in
 489       --  Text_IO, blank includes horizontal tab). Note that Get deals with
 490       --  the Before_LM and Before_LM_PM flags appropriately.
 491
 492       loop
 493          Get (File, C);
 494          exit when not Is_Blank (C);
 495       end loop;
 496
 497       Ungetc (Character'Pos (C), File);
 498       File.Col := File.Col - 1;
 499    end Load_Skip;
 500
 501    ----------------
 502    -- Load_Width --
 503    ----------------
 504
 505    procedure Load_Width
 506      (File  : File_Type;
 507       Width : Field;
 508       Buf   : out String;
 509       Ptr   : in out Integer)
 510    is
 511       ch : int;
 512
 513    begin
 514       FIO.Check_Read_Status (AP (File));
 515
 516       --  If we are immediately before a line mark, then we have no characters.
 517       --  This is always a data error, so we may as well raise it right away.
 518
 519       if File.Before_LM then
 520          raise Data_Error;
 521
 522       else
 523          for J in 1 .. Width loop
 524             ch := Getc (File);
 525
 526             if ch = EOF then
 527                return;
 528
 529             elsif ch = LM then
 530                Ungetc (ch, File);
 531                return;
 532
 533             else
 534                Store_Char (File, ch, Buf, Ptr);
 535             end if;
 536          end loop;
 537       end if;
 538    end Load_Width;
 539
 540    -----------
 541    -- Nextc --
 542    -----------
 543
 544    function Nextc (File : File_Type) return int is
 545       ch : int;
 546
 547    begin
 548       ch := fgetc (File.Stream);
 549
 550       if ch = EOF then
 551          if ferror (File.Stream) /= 0 then
 552             raise Device_Error;
 553          else
 554             return EOF;
 555          end if;
 556
 557       else
 558          Ungetc (ch, File);
 559          return ch;
 560       end if;
 561    end Nextc;
 562
 563    --------------
 564    -- Put_Item --
 565    --------------
 566
 567    procedure Put_Item (File : File_Type; Str : String) is
 568    begin
 569       Check_On_One_Line (File, Str'Length);
 570       Put (File, Str);
 571    end Put_Item;
 572
 573    ----------------
 574    -- Store_Char --
 575    ----------------
 576
 577    procedure Store_Char
 578      (File : File_Type;
 579       ch   : int;
 580       Buf  : in out String;
 581       Ptr  : in out Integer)
 582    is
 583    begin
 584       File.Col := File.Col + 1;
 585
 586       if Ptr < Buf'Last then
 587          Ptr := Ptr + 1;
 588       end if;
 589
 590       Buf (Ptr) := Character'Val (ch);
 591    end Store_Char;
 592
 593    -----------------
 594    -- String_Skip --
 595    -----------------
 596
 597    procedure String_Skip (Str : String; Ptr : out Integer) is
 598    begin
 599       --  Routines calling String_Skip malfunction if Str'Last = Positive'Last.
 600       --  It's too much trouble to make this silly case work, so we just raise
 601       --  Program_Error with an appropriate message. We raise Program_Error
 602       --  rather than Constraint_Error because we don't want this case to be
 603       --  converted to Data_Error.
 604
 605       if Str'Last = Positive'Last then
 606          raise Program_Error with
 607            "string upper bound is Positive'Last, not supported";
 608       end if;
 609
 610       --  Normal case where Str'Last < Positive'Last
 611
 612       Ptr := Str'First;
 613
 614       loop
 615          if Ptr > Str'Last then
 616             raise End_Error;
 617
 618          elsif not Is_Blank (Str (Ptr)) then
 619             return;
 620
 621          else
 622             Ptr := Ptr + 1;
 623          end if;
 624       end loop;
 625    end String_Skip;
 626
 627    ------------
 628    -- Ungetc --
 629    ------------
 630
 631    procedure Ungetc (ch : int; File : File_Type) is
 632    begin
 633       if ch /= EOF then
 634          if ungetc (ch, File.Stream) = EOF then
 635             raise Device_Error;
 636          end if;
 637       end if;
 638    end Ungetc;
 639
 640 end Ada.Text_IO.Generic_Aux;