gcc/ada/a-wtgeau.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUNTIME 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 --                            $Revision: 1.5 $
  10 --                                                                          --
  11 --          Copyright (C) 1992-2000 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNAT was originally developed  by the GNAT team at  New York University. --
  32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 with Interfaces.C_Streams; use Interfaces.C_Streams;
  37 with System.File_IO;
  38 with System.File_Control_Block;
  39
  40 package body Ada.Wide_Text_IO.Generic_Aux is
  41
  42    package FIO renames System.File_IO;
  43    package FCB renames System.File_Control_Block;
  44    subtype AP is FCB.AFCB_Ptr;
  45
  46    ------------------------
  47    -- Check_End_Of_Field --
  48    ------------------------
  49
  50    procedure Check_End_Of_Field
  51      (File  : File_Type;
  52       Buf   : String;
  53       Stop  : Integer;
  54       Ptr   : Integer;
  55       Width : Field)
  56    is
  57    begin
  58       if Ptr > Stop then
  59          return;
  60
  61       elsif Width = 0 then
  62          raise Data_Error;
  63
  64       else
  65          for J in Ptr .. Stop loop
  66             if not Is_Blank (Buf (J)) then
  67                raise Data_Error;
  68             end if;
  69          end loop;
  70       end if;
  71    end Check_End_Of_Field;
  72
  73    -----------------------
  74    -- Check_On_One_Line --
  75    -----------------------
  76
  77    procedure Check_On_One_Line
  78      (File   : File_Type;
  79       Length : Integer)
  80    is
  81    begin
  82       FIO.Check_Write_Status (AP (File));
  83
  84       if File.Line_Length /= 0 then
  85          if Count (Length) > File.Line_Length then
  86             raise Layout_Error;
  87          elsif File.Col + Count (Length) > File.Line_Length + 1 then
  88             New_Line (File);
  89          end if;
  90       end if;
  91    end Check_On_One_Line;
  92
  93    --------------
  94    -- Is_Blank --
  95    --------------
  96
  97    function Is_Blank (C : Character) return Boolean is
  98    begin
  99       return C = ' ' or else C = ASCII.HT;
 100    end Is_Blank;
 101
 102    ----------
 103    -- Load --
 104    ----------
 105
 106    procedure Load
 107      (File   : File_Type;
 108       Buf    : out String;
 109       Ptr    : in out Integer;
 110       Char   : Character;
 111       Loaded : out Boolean)
 112    is
 113       ch : int;
 114
 115    begin
 116       if File.Before_Wide_Character then
 117          Loaded := False;
 118          return;
 119
 120       else
 121          ch := Getc (File);
 122
 123          if ch = Character'Pos (Char) then
 124             Store_Char (File, ch, Buf, Ptr);
 125             Loaded := True;
 126          else
 127             Ungetc (ch, File);
 128             Loaded := False;
 129          end if;
 130       end if;
 131    end Load;
 132
 133    procedure Load
 134      (File   : File_Type;
 135       Buf    : out String;
 136       Ptr    : in out Integer;
 137       Char   : Character)
 138    is
 139       ch : int;
 140
 141    begin
 142       if File.Before_Wide_Character then
 143          null;
 144
 145       else
 146          ch := Getc (File);
 147
 148          if ch = Character'Pos (Char) then
 149             Store_Char (File, ch, Buf, Ptr);
 150          else
 151             Ungetc (ch, File);
 152          end if;
 153       end if;
 154    end Load;
 155
 156    procedure Load
 157      (File   : File_Type;
 158       Buf    : out String;
 159       Ptr    : in out Integer;
 160       Char1  : Character;
 161       Char2  : Character;
 162       Loaded : out Boolean)
 163    is
 164       ch : int;
 165
 166    begin
 167       if File.Before_Wide_Character then
 168          Loaded := False;
 169          return;
 170
 171       else
 172          ch := Getc (File);
 173
 174          if ch = Character'Pos (Char1)
 175            or else ch = Character'Pos (Char2)
 176          then
 177             Store_Char (File, ch, Buf, Ptr);
 178             Loaded := True;
 179          else
 180             Ungetc (ch, File);
 181             Loaded := False;
 182          end if;
 183       end if;
 184    end Load;
 185
 186    procedure Load
 187      (File   : File_Type;
 188       Buf    : out String;
 189       Ptr    : in out Integer;
 190       Char1  : Character;
 191       Char2  : Character)
 192    is
 193       ch : int;
 194
 195    begin
 196       if File.Before_Wide_Character then
 197          null;
 198
 199       else
 200          ch := Getc (File);
 201
 202          if ch = Character'Pos (Char1)
 203            or else ch = Character'Pos (Char2)
 204          then
 205             Store_Char (File, ch, Buf, Ptr);
 206          else
 207             Ungetc (ch, File);
 208          end if;
 209       end if;
 210    end Load;
 211
 212    -----------------
 213    -- Load_Digits --
 214    -----------------
 215
 216    procedure Load_Digits
 217      (File   : File_Type;
 218       Buf    : out String;
 219       Ptr    : in out Integer;
 220       Loaded : out Boolean)
 221    is
 222       ch          : int;
 223       After_Digit : Boolean;
 224
 225    begin
 226       if File.Before_Wide_Character then
 227          Loaded := False;
 228          return;
 229
 230       else
 231          ch := Getc (File);
 232
 233          if ch not in Character'Pos ('0') .. Character'Pos ('9') then
 234             Loaded := False;
 235
 236          else
 237             Loaded := True;
 238             After_Digit := True;
 239
 240             loop
 241                Store_Char (File, ch, Buf, Ptr);
 242                ch := Getc (File);
 243
 244                if ch in Character'Pos ('0') .. Character'Pos ('9') then
 245                   After_Digit := True;
 246
 247                elsif ch = Character'Pos ('_') and then After_Digit then
 248                   After_Digit := False;
 249
 250                else
 251                   exit;
 252                end if;
 253             end loop;
 254          end if;
 255
 256          Ungetc (ch, File);
 257       end if;
 258    end Load_Digits;
 259
 260    procedure Load_Digits
 261      (File   : File_Type;
 262       Buf    : out String;
 263       Ptr    : in out Integer)
 264    is
 265       ch          : int;
 266       After_Digit : Boolean;
 267
 268    begin
 269       if File.Before_Wide_Character then
 270          return;
 271
 272       else
 273          ch := Getc (File);
 274
 275          if ch in Character'Pos ('0') .. Character'Pos ('9') then
 276             After_Digit := True;
 277
 278             loop
 279                Store_Char (File, ch, Buf, Ptr);
 280                ch := Getc (File);
 281
 282                if ch in Character'Pos ('0') .. Character'Pos ('9') then
 283                   After_Digit := True;
 284
 285                elsif ch = Character'Pos ('_') and then After_Digit then
 286                   After_Digit := False;
 287
 288                else
 289                   exit;
 290                end if;
 291             end loop;
 292          end if;
 293
 294          Ungetc (ch, File);
 295       end if;
 296    end Load_Digits;
 297
 298    --------------------------
 299    -- Load_Extended_Digits --
 300    --------------------------
 301
 302    procedure Load_Extended_Digits
 303      (File   : File_Type;
 304       Buf    : out String;
 305       Ptr    : in out Integer;
 306       Loaded : out Boolean)
 307    is
 308       ch          : int;
 309       After_Digit : Boolean := False;
 310
 311    begin
 312       if File.Before_Wide_Character then
 313          Loaded := False;
 314          return;
 315
 316       else
 317          Loaded := False;
 318
 319          loop
 320             ch := Getc (File);
 321
 322             if ch in Character'Pos ('0') .. Character'Pos ('9')
 323                  or else
 324                ch in Character'Pos ('a') .. Character'Pos ('f')
 325                  or else
 326                ch in Character'Pos ('A') .. Character'Pos ('F')
 327             then
 328                After_Digit := True;
 329
 330             elsif ch = Character'Pos ('_') and then After_Digit then
 331                After_Digit := False;
 332
 333             else
 334                exit;
 335             end if;
 336
 337             Store_Char (File, ch, Buf, Ptr);
 338             Loaded := True;
 339          end loop;
 340
 341          Ungetc (ch, File);
 342       end if;
 343    end Load_Extended_Digits;
 344
 345    procedure Load_Extended_Digits
 346      (File   : File_Type;
 347       Buf    : out String;
 348       Ptr    : in out Integer)
 349    is
 350       Junk : Boolean;
 351
 352    begin
 353       Load_Extended_Digits (File, Buf, Ptr, Junk);
 354    end Load_Extended_Digits;
 355
 356    ---------------
 357    -- Load_Skip --
 358    ---------------
 359
 360    procedure Load_Skip (File  : File_Type) is
 361       C : Character;
 362
 363    begin
 364       FIO.Check_Read_Status (AP (File));
 365
 366       --  We need to explicitly test for the case of being before a wide
 367       --  character (greater than 16#7F#). Since no such character can
 368       --  ever legitimately be a valid numeric character, we can
 369       --  immediately signal Data_Error.
 370
 371       if File.Before_Wide_Character then
 372          raise Data_Error;
 373       end if;
 374
 375       --  Otherwise loop till we find a non-blank character (note that as
 376       --  usual in Wide_Text_IO, blank includes horizontal tab). Note that
 377       --  Get_Character deals with Before_LM/Before_LM_PM flags appropriately.
 378
 379       loop
 380          Get_Character (File, C);
 381          exit when not Is_Blank (C);
 382       end loop;
 383
 384       Ungetc (Character'Pos (C), File);
 385       File.Col := File.Col - 1;
 386    end Load_Skip;
 387
 388    ----------------
 389    -- Load_Width --
 390    ----------------
 391
 392    procedure Load_Width
 393      (File  : File_Type;
 394       Width : Field;
 395       Buf   : out String;
 396       Ptr   : in out Integer)
 397    is
 398       ch : int;
 399       WC : Wide_Character;
 400
 401       Bad_Wide_C : Boolean := False;
 402       --  Set True if one of the characters read is not in range of type
 403       --  Character. This is always a Data_Error, but we do not signal it
 404       --  right away, since we have to read the full number of characters.
 405
 406    begin
 407       FIO.Check_Read_Status (AP (File));
 408
 409       --  If we are immediately before a line mark, then we have no characters.
 410       --  This is always a data error, so we may as well raise it right away.
 411
 412       if File.Before_LM then
 413          raise Data_Error;
 414
 415       else
 416          for J in 1 .. Width loop
 417             if File.Before_Wide_Character then
 418                Bad_Wide_C := True;
 419                Store_Char (File, 0, Buf, Ptr);
 420                File.Before_Wide_Character := False;
 421
 422             else
 423                ch := Getc (File);
 424
 425                if ch = EOF then
 426                   exit;
 427
 428                elsif ch = LM then
 429                   Ungetc (ch, File);
 430                   exit;
 431
 432                else
 433                   WC := Get_Wide_Char (Character'Val (ch), File);
 434                   ch := Wide_Character'Pos (WC);
 435
 436                   if ch > 255 then
 437                      Bad_Wide_C := True;
 438                      ch := 0;
 439                   end if;
 440
 441                   Store_Char (File, ch, Buf, Ptr);
 442                end if;
 443             end if;
 444          end loop;
 445
 446          if Bad_Wide_C then
 447             raise Data_Error;
 448          end if;
 449       end if;
 450    end Load_Width;
 451
 452    --------------
 453    -- Put_Item --
 454    --------------
 455
 456    procedure Put_Item (File : File_Type; Str : String) is
 457    begin
 458       Check_On_One_Line (File, Str'Length);
 459
 460       for J in Str'Range loop
 461          Put (File, Wide_Character'Val (Character'Pos (Str (J))));
 462       end loop;
 463    end Put_Item;
 464
 465    ----------------
 466    -- Store_Char --
 467    ----------------
 468
 469    procedure Store_Char
 470      (File : File_Type;
 471       ch   : Integer;
 472       Buf  : out String;
 473       Ptr  : in out Integer)
 474    is
 475    begin
 476       File.Col := File.Col + 1;
 477
 478       if Ptr = Buf'Last then
 479          raise Data_Error;
 480       else
 481          Ptr := Ptr + 1;
 482          Buf (Ptr) := Character'Val (ch);
 483       end if;
 484    end Store_Char;
 485
 486    -----------------
 487    -- String_Skip --
 488    -----------------
 489
 490    procedure String_Skip (Str : String; Ptr : out Integer) is
 491    begin
 492       Ptr := Str'First;
 493
 494       loop
 495          if Ptr > Str'Last then
 496             raise End_Error;
 497
 498          elsif not Is_Blank (Str (Ptr)) then
 499             return;
 500
 501          else
 502             Ptr := Ptr + 1;
 503          end if;
 504       end loop;
 505    end String_Skip;
 506
 507    ------------
 508    -- Ungetc --
 509    ------------
 510
 511    procedure Ungetc (ch : int; File : File_Type) is
 512    begin
 513       if ch /= EOF then
 514          if ungetc (ch, File.Stream) = EOF then
 515             raise Device_Error;
 516          end if;
 517       end if;
 518    end Ungetc;
 519
 520 end Ada.Wide_Text_IO.Generic_Aux;