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