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-2007, 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.Wide_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    -- Is_Blank --
  92    --------------
  93
  94    function Is_Blank (C : Character) return Boolean is
  95    begin
  96       return C = ' ' or else C = ASCII.HT;
  97    end Is_Blank;
  98
  99    ----------
 100    -- Load --
 101    ----------
 102
 103    procedure Load
 104      (File   : File_Type;
 105       Buf    : out String;
 106       Ptr    : in out Integer;
 107       Char   : Character;
 108       Loaded : out Boolean)
 109    is
 110       ch : int;
 111
 112    begin
 113       if File.Before_Wide_Character then
 114          Loaded := False;
 115          return;
 116
 117       else
 118          ch := Getc (File);
 119
 120          if ch = Character'Pos (Char) then
 121             Store_Char (File, ch, Buf, Ptr);
 122             Loaded := True;
 123          else
 124             Ungetc (ch, File);
 125             Loaded := False;
 126          end if;
 127       end if;
 128    end Load;
 129
 130    procedure Load
 131      (File   : File_Type;
 132       Buf    : out String;
 133       Ptr    : in out Integer;
 134       Char   : Character)
 135    is
 136       ch : int;
 137
 138    begin
 139       if File.Before_Wide_Character then
 140          null;
 141
 142       else
 143          ch := Getc (File);
 144
 145          if ch = Character'Pos (Char) then
 146             Store_Char (File, ch, Buf, Ptr);
 147          else
 148             Ungetc (ch, File);
 149          end if;
 150       end if;
 151    end Load;
 152
 153    procedure Load
 154      (File   : File_Type;
 155       Buf    : out String;
 156       Ptr    : in out Integer;
 157       Char1  : Character;
 158       Char2  : Character;
 159       Loaded : out Boolean)
 160    is
 161       ch : int;
 162
 163    begin
 164       if File.Before_Wide_Character then
 165          Loaded := False;
 166          return;
 167
 168       else
 169          ch := Getc (File);
 170
 171          if ch = Character'Pos (Char1)
 172            or else ch = Character'Pos (Char2)
 173          then
 174             Store_Char (File, ch, Buf, Ptr);
 175             Loaded := True;
 176          else
 177             Ungetc (ch, File);
 178             Loaded := False;
 179          end if;
 180       end if;
 181    end Load;
 182
 183    procedure Load
 184      (File   : File_Type;
 185       Buf    : out String;
 186       Ptr    : in out Integer;
 187       Char1  : Character;
 188       Char2  : Character)
 189    is
 190       ch : int;
 191
 192    begin
 193       if File.Before_Wide_Character then
 194          null;
 195
 196       else
 197          ch := Getc (File);
 198
 199          if ch = Character'Pos (Char1)
 200            or else ch = Character'Pos (Char2)
 201          then
 202             Store_Char (File, ch, Buf, Ptr);
 203          else
 204             Ungetc (ch, File);
 205          end if;
 206       end if;
 207    end Load;
 208
 209    -----------------
 210    -- Load_Digits --
 211    -----------------
 212
 213    procedure Load_Digits
 214      (File   : File_Type;
 215       Buf    : out String;
 216       Ptr    : in out Integer;
 217       Loaded : out Boolean)
 218    is
 219       ch          : int;
 220       After_Digit : Boolean;
 221
 222    begin
 223       if File.Before_Wide_Character then
 224          Loaded := False;
 225          return;
 226
 227       else
 228          ch := Getc (File);
 229
 230          if ch not in Character'Pos ('0') .. Character'Pos ('9') then
 231             Loaded := False;
 232
 233          else
 234             Loaded := True;
 235             After_Digit := True;
 236
 237             loop
 238                Store_Char (File, ch, Buf, Ptr);
 239                ch := Getc (File);
 240
 241                if ch in Character'Pos ('0') .. Character'Pos ('9') then
 242                   After_Digit := True;
 243
 244                elsif ch = Character'Pos ('_') and then After_Digit then
 245                   After_Digit := False;
 246
 247                else
 248                   exit;
 249                end if;
 250             end loop;
 251          end if;
 252
 253          Ungetc (ch, File);
 254       end if;
 255    end Load_Digits;
 256
 257    procedure Load_Digits
 258      (File   : File_Type;
 259       Buf    : out String;
 260       Ptr    : in out Integer)
 261    is
 262       ch          : int;
 263       After_Digit : Boolean;
 264
 265    begin
 266       if File.Before_Wide_Character then
 267          return;
 268
 269       else
 270          ch := Getc (File);
 271
 272          if ch in Character'Pos ('0') .. Character'Pos ('9') then
 273             After_Digit := True;
 274
 275             loop
 276                Store_Char (File, ch, Buf, Ptr);
 277                ch := Getc (File);
 278
 279                if ch in Character'Pos ('0') .. Character'Pos ('9') then
 280                   After_Digit := True;
 281
 282                elsif ch = Character'Pos ('_') and then After_Digit then
 283                   After_Digit := False;
 284
 285                else
 286                   exit;
 287                end if;
 288             end loop;
 289          end if;
 290
 291          Ungetc (ch, File);
 292       end if;
 293    end Load_Digits;
 294
 295    --------------------------
 296    -- Load_Extended_Digits --
 297    --------------------------
 298
 299    procedure Load_Extended_Digits
 300      (File   : File_Type;
 301       Buf    : out String;
 302       Ptr    : in out Integer;
 303       Loaded : out Boolean)
 304    is
 305       ch          : int;
 306       After_Digit : Boolean := False;
 307
 308    begin
 309       if File.Before_Wide_Character then
 310          Loaded := False;
 311          return;
 312
 313       else
 314          Loaded := False;
 315
 316          loop
 317             ch := Getc (File);
 318
 319             if ch in Character'Pos ('0') .. Character'Pos ('9')
 320                  or else
 321                ch in Character'Pos ('a') .. Character'Pos ('f')
 322                  or else
 323                ch in Character'Pos ('A') .. Character'Pos ('F')
 324             then
 325                After_Digit := True;
 326
 327             elsif ch = Character'Pos ('_') and then After_Digit then
 328                After_Digit := False;
 329
 330             else
 331                exit;
 332             end if;
 333
 334             Store_Char (File, ch, Buf, Ptr);
 335             Loaded := True;
 336          end loop;
 337
 338          Ungetc (ch, File);
 339       end if;
 340    end Load_Extended_Digits;
 341
 342    procedure Load_Extended_Digits
 343      (File   : File_Type;
 344       Buf    : out String;
 345       Ptr    : in out Integer)
 346    is
 347       Junk : Boolean;
 348       pragma Unreferenced (Junk);
 349    begin
 350       Load_Extended_Digits (File, Buf, Ptr, Junk);
 351    end Load_Extended_Digits;
 352
 353    ---------------
 354    -- Load_Skip --
 355    ---------------
 356
 357    procedure Load_Skip (File  : File_Type) is
 358       C : Character;
 359
 360    begin
 361       FIO.Check_Read_Status (AP (File));
 362
 363       --  We need to explicitly test for the case of being before a wide
 364       --  character (greater than 16#7F#). Since no such character can
 365       --  ever legitimately be a valid numeric character, we can
 366       --  immediately signal Data_Error.
 367
 368       if File.Before_Wide_Character then
 369          raise Data_Error;
 370       end if;
 371
 372       --  Otherwise loop till we find a non-blank character (note that as
 373       --  usual in Wide_Text_IO, blank includes horizontal tab). Note that
 374       --  Get_Character deals with Before_LM/Before_LM_PM flags appropriately.
 375
 376       loop
 377          Get_Character (File, C);
 378          exit when not Is_Blank (C);
 379       end loop;
 380
 381       Ungetc (Character'Pos (C), File);
 382       File.Col := File.Col - 1;
 383    end Load_Skip;
 384
 385    ----------------
 386    -- Load_Width --
 387    ----------------
 388
 389    procedure Load_Width
 390      (File  : File_Type;
 391       Width : Field;
 392       Buf   : out String;
 393       Ptr   : in out Integer)
 394    is
 395       ch : int;
 396       WC : Wide_Character;
 397
 398       Bad_Wide_C : Boolean := False;
 399       --  Set True if one of the characters read is not in range of type
 400       --  Character. This is always a Data_Error, but we do not signal it
 401       --  right away, since we have to read the full number of characters.
 402
 403    begin
 404       FIO.Check_Read_Status (AP (File));
 405
 406       --  If we are immediately before a line mark, then we have no characters.
 407       --  This is always a data error, so we may as well raise it right away.
 408
 409       if File.Before_LM then
 410          raise Data_Error;
 411
 412       else
 413          for J in 1 .. Width loop
 414             if File.Before_Wide_Character then
 415                Bad_Wide_C := True;
 416                Store_Char (File, 0, Buf, Ptr);
 417                File.Before_Wide_Character := False;
 418
 419             else
 420                ch := Getc (File);
 421
 422                if ch = EOF then
 423                   exit;
 424
 425                elsif ch = LM then
 426                   Ungetc (ch, File);
 427                   exit;
 428
 429                else
 430                   WC := Get_Wide_Char (Character'Val (ch), File);
 431                   ch := Wide_Character'Pos (WC);
 432
 433                   if ch > 255 then
 434                      Bad_Wide_C := True;
 435                      ch := 0;
 436                   end if;
 437
 438                   Store_Char (File, ch, Buf, Ptr);
 439                end if;
 440             end if;
 441          end loop;
 442
 443          if Bad_Wide_C then
 444             raise Data_Error;
 445          end if;
 446       end if;
 447    end Load_Width;
 448
 449    --------------
 450    -- Put_Item --
 451    --------------
 452
 453    procedure Put_Item (File : File_Type; Str : String) is
 454    begin
 455       Check_On_One_Line (File, Str'Length);
 456
 457       for J in Str'Range loop
 458          Put (File, Wide_Character'Val (Character'Pos (Str (J))));
 459       end loop;
 460    end Put_Item;
 461
 462    ----------------
 463    -- Store_Char --
 464    ----------------
 465
 466    procedure Store_Char
 467      (File : File_Type;
 468       ch   : Integer;
 469       Buf  : out String;
 470       Ptr  : in out Integer)
 471    is
 472    begin
 473       File.Col := File.Col + 1;
 474
 475       if Ptr = Buf'Last then
 476          raise Data_Error;
 477       else
 478          Ptr := Ptr + 1;
 479          Buf (Ptr) := Character'Val (ch);
 480       end if;
 481    end Store_Char;
 482
 483    -----------------
 484    -- String_Skip --
 485    -----------------
 486
 487    procedure String_Skip (Str : String; Ptr : out Integer) is
 488    begin
 489       Ptr := Str'First;
 490
 491       loop
 492          if Ptr > Str'Last then
 493             raise End_Error;
 494
 495          elsif not Is_Blank (Str (Ptr)) then
 496             return;
 497
 498          else
 499             Ptr := Ptr + 1;
 500          end if;
 501       end loop;
 502    end String_Skip;
 503
 504    ------------
 505    -- Ungetc --
 506    ------------
 507
 508    procedure Ungetc (ch : int; File : File_Type) is
 509    begin
 510       if ch /= EOF then
 511          if ungetc (ch, File.Stream) = EOF then
 512             raise Device_Error;
 513          end if;
 514       end if;
 515    end Ungetc;
 516
 517 end Ada.Wide_Text_IO.Generic_Aux;