gcc/ada/a-wtgeau.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --         A D A . 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-2014, 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_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_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_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_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_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_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_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_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       pragma Unreferenced (Junk);
 347    begin
 348       Load_Extended_Digits (File, Buf, Ptr, Junk);
 349    end Load_Extended_Digits;
 350
 351    ---------------
 352    -- Load_Skip --
 353    ---------------
 354
 355    procedure Load_Skip (File  : File_Type) is
 356       C : Character;
 357
 358    begin
 359       FIO.Check_Read_Status (AP (File));
 360
 361       --  We need to explicitly test for the case of being before a wide
 362       --  character (greater than 16#7F#). Since no such character can
 363       --  ever legitimately be a valid numeric character, we can
 364       --  immediately signal Data_Error.
 365
 366       if File.Before_Wide_Character then
 367          raise Data_Error;
 368       end if;
 369
 370       --  Otherwise loop till we find a non-blank character (note that as
 371       --  usual in Wide_Text_IO, blank includes horizontal tab). Note that
 372       --  Get_Character deals with Before_LM/Before_LM_PM flags appropriately.
 373
 374       loop
 375          Get_Character (File, C);
 376          exit when not Is_Blank (C);
 377       end loop;
 378
 379       Ungetc (Character'Pos (C), File);
 380       File.Col := File.Col - 1;
 381    end Load_Skip;
 382
 383    ----------------
 384    -- Load_Width --
 385    ----------------
 386
 387    procedure Load_Width
 388      (File  : File_Type;
 389       Width : Field;
 390       Buf   : out String;
 391       Ptr   : in out Integer)
 392    is
 393       ch : int;
 394       WC : Wide_Character;
 395
 396       Bad_Wide_C : Boolean := False;
 397       --  Set True if one of the characters read is not in range of type
 398       --  Character. This is always a Data_Error, but we do not signal it
 399       --  right away, since we have to read the full number of characters.
 400
 401    begin
 402       FIO.Check_Read_Status (AP (File));
 403
 404       --  If we are immediately before a line mark, then we have no characters.
 405       --  This is always a data error, so we may as well raise it right away.
 406
 407       if File.Before_LM then
 408          raise Data_Error;
 409
 410       else
 411          for J in 1 .. Width loop
 412             if File.Before_Wide_Character then
 413                Bad_Wide_C := True;
 414                Store_Char (File, 0, Buf, Ptr);
 415                File.Before_Wide_Character := False;
 416
 417             else
 418                ch := Getc (File);
 419
 420                if ch = EOF then
 421                   exit;
 422
 423                elsif ch = LM then
 424                   Ungetc (ch, File);
 425                   exit;
 426
 427                else
 428                   WC := Get_Wide_Char (Character'Val (ch), File);
 429                   ch := Wide_Character'Pos (WC);
 430
 431                   if ch > 255 then
 432                      Bad_Wide_C := True;
 433                      ch := 0;
 434                   end if;
 435
 436                   Store_Char (File, ch, Buf, Ptr);
 437                end if;
 438             end if;
 439          end loop;
 440
 441          if Bad_Wide_C then
 442             raise Data_Error;
 443          end if;
 444       end if;
 445    end Load_Width;
 446
 447    --------------
 448    -- Put_Item --
 449    --------------
 450
 451    procedure Put_Item (File : File_Type; Str : String) is
 452    begin
 453       Check_On_One_Line (File, Str'Length);
 454
 455       for J in Str'Range loop
 456          Put (File, Wide_Character'Val (Character'Pos (Str (J))));
 457       end loop;
 458    end Put_Item;
 459
 460    ----------------
 461    -- Store_Char --
 462    ----------------
 463
 464    procedure Store_Char
 465      (File : File_Type;
 466       ch   : Integer;
 467       Buf  : out String;
 468       Ptr  : in out Integer)
 469    is
 470    begin
 471       File.Col := File.Col + 1;
 472
 473       if Ptr = Buf'Last then
 474          raise Data_Error;
 475       else
 476          Ptr := Ptr + 1;
 477          Buf (Ptr) := Character'Val (ch);
 478       end if;
 479    end Store_Char;
 480
 481    -----------------
 482    -- String_Skip --
 483    -----------------
 484
 485    procedure String_Skip (Str : String; Ptr : out Integer) is
 486    begin
 487       --  Routines calling String_Skip malfunction if Str'Last = Positive'Last.
 488       --  It's too much trouble to make this silly case work, so we just raise
 489       --  Program_Error with an appropriate message. We raise Program_Error
 490       --  rather than Constraint_Error because we don't want this case to be
 491       --  converted to Data_Error.
 492
 493       if Str'Last = Positive'Last then
 494          raise Program_Error with
 495            "string upper bound is Positive'Last, not supported";
 496       end if;
 497
 498       --  Normal case where Str'Last < Positive'Last
 499
 500       Ptr := Str'First;
 501
 502       loop
 503          if Ptr > Str'Last then
 504             raise End_Error;
 505
 506          elsif not Is_Blank (Str (Ptr)) then
 507             return;
 508
 509          else
 510             Ptr := Ptr + 1;
 511          end if;
 512       end loop;
 513    end String_Skip;
 514
 515    ------------
 516    -- Ungetc --
 517    ------------
 518
 519    procedure Ungetc (ch : int; File : File_Type) is
 520    begin
 521       if ch /= EOF then
 522          if ungetc (ch, File.Stream) = EOF then
 523             raise Device_Error;
 524          end if;
 525       end if;
 526    end Ungetc;
 527
 528 end Ada.Wide_Text_IO.Generic_Aux;