gcc/ada/libgnat/a-ztgeau.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --    A D A . W I D E _ W I D E _ 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-2023, 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.Wide_Wide_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    -- Is_Blank --
  90    --------------
  91
  92    function Is_Blank (C : Character) return Boolean is
  93    begin
  94       return C = ' ' or else C = ASCII.HT;
  95    end Is_Blank;
  96
  97    ----------
  98    -- Load --
  99    ----------
 100
 101    procedure Load
 102      (File   : File_Type;
 103       Buf    : out String;
 104       Ptr    : in out Integer;
 105       Char   : Character;
 106       Loaded : out Boolean)
 107    is
 108       ch : int;
 109
 110    begin
 111       if File.Before_Wide_Wide_Character then
 112          Loaded := False;
 113          return;
 114
 115       else
 116          ch := Getc (File);
 117
 118          if ch = Character'Pos (Char) then
 119             Store_Char (File, ch, Buf, Ptr);
 120             Loaded := True;
 121          else
 122             Ungetc (ch, File);
 123             Loaded := False;
 124          end if;
 125       end if;
 126    end Load;
 127
 128    procedure Load
 129      (File   : File_Type;
 130       Buf    : out String;
 131       Ptr    : in out Integer;
 132       Char   : Character)
 133    is
 134       ch : int;
 135
 136    begin
 137       if File.Before_Wide_Wide_Character then
 138          null;
 139
 140       else
 141          ch := Getc (File);
 142
 143          if ch = Character'Pos (Char) then
 144             Store_Char (File, ch, Buf, Ptr);
 145          else
 146             Ungetc (ch, File);
 147          end if;
 148       end if;
 149    end Load;
 150
 151    procedure Load
 152      (File   : File_Type;
 153       Buf    : out String;
 154       Ptr    : in out Integer;
 155       Char1  : Character;
 156       Char2  : Character;
 157       Loaded : out Boolean)
 158    is
 159       ch : int;
 160
 161    begin
 162       if File.Before_Wide_Wide_Character then
 163          Loaded := False;
 164          return;
 165
 166       else
 167          ch := Getc (File);
 168
 169          if ch = Character'Pos (Char1)
 170            or else ch = Character'Pos (Char2)
 171          then
 172             Store_Char (File, ch, Buf, Ptr);
 173             Loaded := True;
 174          else
 175             Ungetc (ch, File);
 176             Loaded := False;
 177          end if;
 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       if File.Before_Wide_Wide_Character then
 192          null;
 193
 194       else
 195          ch := Getc (File);
 196
 197          if ch = Character'Pos (Char1)
 198            or else ch = Character'Pos (Char2)
 199          then
 200             Store_Char (File, ch, Buf, Ptr);
 201          else
 202             Ungetc (ch, File);
 203          end if;
 204       end if;
 205    end Load;
 206
 207    -----------------
 208    -- Load_Digits --
 209    -----------------
 210
 211    procedure Load_Digits
 212      (File   : File_Type;
 213       Buf    : out String;
 214       Ptr    : in out Integer;
 215       Loaded : out Boolean)
 216    is
 217       ch          : int;
 218       After_Digit : Boolean;
 219
 220    begin
 221       if File.Before_Wide_Wide_Character then
 222          Loaded := False;
 223          return;
 224
 225       else
 226          ch := Getc (File);
 227
 228          if ch not in Character'Pos ('0') .. Character'Pos ('9') then
 229             Loaded := False;
 230
 231          else
 232             Loaded := True;
 233             After_Digit := True;
 234
 235             loop
 236                Store_Char (File, ch, Buf, Ptr);
 237                ch := Getc (File);
 238
 239                if ch in Character'Pos ('0') .. Character'Pos ('9') then
 240                   After_Digit := True;
 241
 242                elsif ch = Character'Pos ('_') and then After_Digit then
 243                   After_Digit := False;
 244
 245                else
 246                   exit;
 247                end if;
 248             end loop;
 249          end if;
 250
 251          Ungetc (ch, File);
 252       end if;
 253    end Load_Digits;
 254
 255    procedure Load_Digits
 256      (File   : File_Type;
 257       Buf    : out String;
 258       Ptr    : in out Integer)
 259    is
 260       ch          : int;
 261       After_Digit : Boolean;
 262
 263    begin
 264       if File.Before_Wide_Wide_Character then
 265          return;
 266
 267       else
 268          ch := Getc (File);
 269
 270          if ch in Character'Pos ('0') .. Character'Pos ('9') then
 271             After_Digit := True;
 272
 273             loop
 274                Store_Char (File, ch, Buf, Ptr);
 275                ch := Getc (File);
 276
 277                if ch in Character'Pos ('0') .. Character'Pos ('9') then
 278                   After_Digit := True;
 279
 280                elsif ch = Character'Pos ('_') and then After_Digit then
 281                   After_Digit := False;
 282
 283                else
 284                   exit;
 285                end if;
 286             end loop;
 287          end if;
 288
 289          Ungetc (ch, File);
 290       end if;
 291    end Load_Digits;
 292
 293    --------------------------
 294    -- Load_Extended_Digits --
 295    --------------------------
 296
 297    procedure Load_Extended_Digits
 298      (File   : File_Type;
 299       Buf    : out String;
 300       Ptr    : in out Integer;
 301       Loaded : out Boolean)
 302    is
 303       ch          : int;
 304       After_Digit : Boolean := False;
 305
 306    begin
 307       if File.Before_Wide_Wide_Character then
 308          Loaded := False;
 309          return;
 310
 311       else
 312          Loaded := False;
 313
 314          loop
 315             ch := Getc (File);
 316
 317             if ch in Character'Pos ('0') .. Character'Pos ('9')
 318                  or else
 319                ch in Character'Pos ('a') .. Character'Pos ('f')
 320                  or else
 321                ch in Character'Pos ('A') .. Character'Pos ('F')
 322             then
 323                After_Digit := True;
 324
 325             elsif ch = Character'Pos ('_') and then After_Digit then
 326                After_Digit := False;
 327
 328             else
 329                exit;
 330             end if;
 331
 332             Store_Char (File, ch, Buf, Ptr);
 333             Loaded := True;
 334          end loop;
 335
 336          Ungetc (ch, File);
 337       end if;
 338    end Load_Extended_Digits;
 339
 340    procedure Load_Extended_Digits
 341      (File   : File_Type;
 342       Buf    : out String;
 343       Ptr    : in out Integer)
 344    is
 345       Junk : Boolean;
 346    begin
 347       Load_Extended_Digits (File, Buf, Ptr, Junk);
 348    end Load_Extended_Digits;
 349
 350    ------------------
 351    -- Load_Integer --
 352    ------------------
 353
 354    procedure Load_Integer
 355      (File : File_Type;
 356       Buf  : out String;
 357       Ptr  : in out Natural)
 358    is
 359       Hash_Loc : Natural;
 360       Loaded   : Boolean;
 361
 362    begin
 363       Load_Skip (File);
 364
 365       --  Note: it is a bit strange to allow a minus sign here, but it seems
 366       --  consistent with the general behavior expected by the ACVC tests
 367       --  which is to scan past junk and then signal data error, see ACVC
 368       --  test CE3704F, case (6), which is for signed integer exponents,
 369       --  which seems a similar case.
 370
 371       Load (File, Buf, Ptr, '+', '-');
 372       Load_Digits (File, Buf, Ptr, Loaded);
 373
 374       if Loaded then
 375
 376          --  Deal with based literal. We recognize either the standard '#' or
 377          --  the allowed alternative replacement ':' (see RM J.2(3)).
 378
 379          Load (File, Buf, Ptr, '#', ':', Loaded);
 380
 381          if Loaded then
 382             Hash_Loc := Ptr;
 383             Load_Extended_Digits (File, Buf, Ptr);
 384             Load (File, Buf, Ptr, Buf (Hash_Loc));
 385          end if;
 386
 387          --  Deal with exponent
 388
 389          Load (File, Buf, Ptr, 'E', 'e', Loaded);
 390
 391          if Loaded then
 392
 393             --  Note: it is strange to allow a minus sign, since the syntax
 394             --  does not, but that is what ACVC test CE3704F, case (6) wants
 395             --  for the signed case, and there seems no good reason to treat
 396             --  exponents differently for the signed and unsigned cases.
 397
 398             Load (File, Buf, Ptr, '+', '-');
 399             Load_Digits (File, Buf, Ptr);
 400          end if;
 401       end if;
 402    end Load_Integer;
 403
 404    ---------------
 405    -- Load_Real --
 406    ---------------
 407
 408    procedure Load_Real
 409      (File : File_Type;
 410       Buf  : out String;
 411       Ptr  : in out Natural)
 412    is
 413       Loaded : Boolean;
 414
 415    begin
 416       --  Skip initial blanks and load possible sign
 417
 418       Load_Skip (File);
 419       Load (File, Buf, Ptr, '+', '-');
 420
 421       --  Case of .nnnn
 422
 423       Load (File, Buf, Ptr, '.', Loaded);
 424
 425       if Loaded then
 426          Load_Digits (File, Buf, Ptr, Loaded);
 427
 428          --  Hopeless junk if no digits loaded
 429
 430          if not Loaded then
 431             return;
 432          end if;
 433
 434       --  Otherwise must have digits to start
 435
 436       else
 437          Load_Digits (File, Buf, Ptr, Loaded);
 438
 439          --  Hopeless junk if no digits loaded
 440
 441          if not Loaded then
 442             return;
 443          end if;
 444
 445          --  Deal with based case. We recognize either the standard '#' or the
 446          --  allowed alternative replacement ':' (see RM J.2(3)).
 447
 448          Load (File, Buf, Ptr, '#', ':', Loaded);
 449
 450          if Loaded then
 451
 452             --  Case of nnn#.xxx#
 453
 454             Load (File, Buf, Ptr, '.', Loaded);
 455
 456             if Loaded then
 457                Load_Extended_Digits (File, Buf, Ptr);
 458                Load (File, Buf, Ptr, '#', ':');
 459
 460             --  Case of nnn#xxx.[xxx]# or nnn#xxx#
 461
 462             else
 463                Load_Extended_Digits (File, Buf, Ptr);
 464                Load (File, Buf, Ptr, '.', Loaded);
 465
 466                if Loaded then
 467                   Load_Extended_Digits (File, Buf, Ptr);
 468                end if;
 469
 470                --  As usual, it seems strange to allow mixed base characters,
 471                --  but that is what ACVC tests expect, see CE3804M, case (3).
 472
 473                Load (File, Buf, Ptr, '#', ':');
 474             end if;
 475
 476          --  Case of nnn.[nnn] or nnn
 477
 478          else
 479             --  Prevent the potential processing of '.' in cases where the
 480             --  initial digits have a trailing underscore.
 481
 482             if Buf (Ptr) = '_' then
 483                return;
 484             end if;
 485
 486             Load (File, Buf, Ptr, '.', Loaded);
 487
 488             if Loaded then
 489                Load_Digits (File, Buf, Ptr);
 490             end if;
 491          end if;
 492       end if;
 493
 494       --  Deal with exponent
 495
 496       Load (File, Buf, Ptr, 'E', 'e', Loaded);
 497
 498       if Loaded then
 499          Load (File, Buf, Ptr, '+', '-');
 500          Load_Digits (File, Buf, Ptr);
 501       end if;
 502    end Load_Real;
 503
 504    ---------------
 505    -- Load_Skip --
 506    ---------------
 507
 508    procedure Load_Skip (File  : File_Type) is
 509       C : Character;
 510
 511    begin
 512       FIO.Check_Read_Status (AP (File));
 513
 514       --  We need to explicitly test for the case of being before a wide
 515       --  character (greater than 16#7F#). Since no such character can
 516       --  ever legitimately be a valid numeric character, we can
 517       --  immediately signal Data_Error.
 518
 519       if File.Before_Wide_Wide_Character then
 520          raise Data_Error;
 521       end if;
 522
 523       --  Otherwise loop till we find a non-blank character (note that as
 524       --  usual in Wide_Wide_Text_IO, blank includes horizontal tab). Note that
 525       --  Get_Character deals with Before_LM/Before_LM_PM flags appropriately.
 526
 527       loop
 528          Get_Character (File, C);
 529          exit when not Is_Blank (C);
 530       end loop;
 531
 532       Ungetc (Character'Pos (C), File);
 533       File.Col := File.Col - 1;
 534    end Load_Skip;
 535
 536    ----------------
 537    -- Load_Width --
 538    ----------------
 539
 540    procedure Load_Width
 541      (File  : File_Type;
 542       Width : Field;
 543       Buf   : out String;
 544       Ptr   : in out Integer)
 545    is
 546       ch : int;
 547       WC : Wide_Wide_Character;
 548
 549       Bad_Wide_Wide_C : Boolean := False;
 550       --  Set True if one of the characters read is not in range of type
 551       --  Character. This is always a Data_Error, but we do not signal it
 552       --  right away, since we have to read the full number of characters.
 553
 554    begin
 555       FIO.Check_Read_Status (AP (File));
 556
 557       --  If we are immediately before a line mark, then we have no characters.
 558       --  This is always a data error, so we may as well raise it right away.
 559
 560       if File.Before_LM then
 561          raise Data_Error;
 562
 563       else
 564          for J in 1 .. Width loop
 565             if File.Before_Wide_Wide_Character then
 566                Bad_Wide_Wide_C := True;
 567                Store_Char (File, 0, Buf, Ptr);
 568                File.Before_Wide_Wide_Character := False;
 569
 570             else
 571                ch := Getc (File);
 572
 573                if ch = EOF then
 574                   exit;
 575
 576                elsif ch = LM then
 577                   Ungetc (ch, File);
 578                   exit;
 579
 580                else
 581                   WC := Get_Wide_Wide_Char (Character'Val (ch), File);
 582                   ch := Wide_Wide_Character'Pos (WC);
 583
 584                   if ch > 255 then
 585                      Bad_Wide_Wide_C := True;
 586                      ch := 0;
 587                   end if;
 588
 589                   Store_Char (File, ch, Buf, Ptr);
 590                end if;
 591             end if;
 592          end loop;
 593
 594          if Bad_Wide_Wide_C then
 595             raise Data_Error;
 596          end if;
 597       end if;
 598    end Load_Width;
 599
 600    --------------
 601    -- Put_Item --
 602    --------------
 603
 604    procedure Put_Item (File : File_Type; Str : String) is
 605    begin
 606       Check_On_One_Line (File, Str'Length);
 607
 608       for J in Str'Range loop
 609          Put (File, Wide_Wide_Character'Val (Character'Pos (Str (J))));
 610       end loop;
 611    end Put_Item;
 612
 613    ----------------
 614    -- Store_Char --
 615    ----------------
 616
 617    procedure Store_Char
 618      (File : File_Type;
 619       ch   : Integer;
 620       Buf  : out String;
 621       Ptr  : in out Integer)
 622    is
 623    begin
 624       File.Col := File.Col + 1;
 625
 626       if Ptr = Buf'Last then
 627          raise Data_Error;
 628       else
 629          Ptr := Ptr + 1;
 630          Buf (Ptr) := Character'Val (ch);
 631       end if;
 632    end Store_Char;
 633
 634    -----------------
 635    -- String_Skip --
 636    -----------------
 637
 638    procedure String_Skip (Str : String; Ptr : out Integer) is
 639    begin
 640       --  Routines calling String_Skip malfunction if Str'Last = Positive'Last.
 641       --  It's too much trouble to make this silly case work, so we just raise
 642       --  Program_Error with an appropriate message. We raise Program_Error
 643       --  rather than Constraint_Error because we don't want this case to be
 644       --  converted to Data_Error.
 645
 646       if Str'Last = Positive'Last then
 647          raise Program_Error with
 648            "string upper bound is Positive'Last, not supported";
 649       end if;
 650
 651       --  Normal case where Str'Last < Positive'Last
 652
 653       Ptr := Str'First;
 654
 655       loop
 656          if Ptr > Str'Last then
 657             raise End_Error;
 658
 659          elsif not Is_Blank (Str (Ptr)) then
 660             return;
 661
 662          else
 663             Ptr := Ptr + 1;
 664          end if;
 665       end loop;
 666    end String_Skip;
 667
 668    ------------
 669    -- Ungetc --
 670    ------------
 671
 672    procedure Ungetc (ch : int; File : File_Type) is
 673    begin
 674       if ch /= EOF then
 675          if ungetc (ch, File.Stream) = EOF then
 676             raise Device_Error;
 677          end if;
 678       end if;
 679    end Ungetc;
 680
 681 end Ada.Wide_Wide_Text_IO.Generic_Aux;