gcc/ada/s-stratt.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --             S Y S T E M . S T R E A M _ A T T R I B U T E S              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2009, 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 Ada.IO_Exceptions;
  33 with Ada.Streams; use Ada.Streams;
  34 with Ada.Unchecked_Conversion;
  35
  36 package body System.Stream_Attributes is
  37
  38    Err : exception renames Ada.IO_Exceptions.End_Error;
  39    --  Exception raised if insufficient data read (note that the RM implies
  40    --  that Data_Error might be the appropriate choice, but AI95-00132
  41    --  decides with a binding interpretation that End_Error is preferred).
  42
  43    SU : constant := System.Storage_Unit;
  44
  45    subtype SEA is Ada.Streams.Stream_Element_Array;
  46    subtype SEO is Ada.Streams.Stream_Element_Offset;
  47
  48    generic function UC renames Ada.Unchecked_Conversion;
  49
  50    --  Subtypes used to define Stream_Element_Array values that map
  51    --  into the elementary types, using unchecked conversion.
  52
  53    Thin_Pointer_Size : constant := System.Address'Size;
  54    Fat_Pointer_Size  : constant := System.Address'Size * 2;
  55
  56    subtype S_AD  is SEA (1 .. (Fat_Pointer_Size              + SU - 1) / SU);
  57    subtype S_AS  is SEA (1 .. (Thin_Pointer_Size             + SU - 1) / SU);
  58    subtype S_B   is SEA (1 .. (Boolean'Size                  + SU - 1) / SU);
  59    subtype S_C   is SEA (1 .. (Character'Size                + SU - 1) / SU);
  60    subtype S_F   is SEA (1 .. (Float'Size                    + SU - 1) / SU);
  61    subtype S_I   is SEA (1 .. (Integer'Size                  + SU - 1) / SU);
  62    subtype S_LF  is SEA (1 .. (Long_Float'Size               + SU - 1) / SU);
  63    subtype S_LI  is SEA (1 .. (Long_Integer'Size             + SU - 1) / SU);
  64    subtype S_LLF is SEA (1 .. (Long_Long_Float'Size          + SU - 1) / SU);
  65    subtype S_LLI is SEA (1 .. (Long_Long_Integer'Size        + SU - 1) / SU);
  66    subtype S_LLU is SEA (1 .. (UST.Long_Long_Unsigned'Size   + SU - 1) / SU);
  67    subtype S_LU  is SEA (1 .. (UST.Long_Unsigned'Size        + SU - 1) / SU);
  68    subtype S_SF  is SEA (1 .. (Short_Float'Size              + SU - 1) / SU);
  69    subtype S_SI  is SEA (1 .. (Short_Integer'Size            + SU - 1) / SU);
  70    subtype S_SSI is SEA (1 .. (Short_Short_Integer'Size      + SU - 1) / SU);
  71    subtype S_SSU is SEA (1 .. (UST.Short_Short_Unsigned'Size + SU - 1) / SU);
  72    subtype S_SU  is SEA (1 .. (UST.Short_Unsigned'Size       + SU - 1) / SU);
  73    subtype S_U   is SEA (1 .. (UST.Unsigned'Size             + SU - 1) / SU);
  74    subtype S_WC  is SEA (1 .. (Wide_Character'Size           + SU - 1) / SU);
  75    subtype S_WWC is SEA (1 .. (Wide_Wide_Character'Size      + SU - 1) / SU);
  76
  77    --  Unchecked conversions from the elementary type to the stream type
  78
  79    function From_AD  is new UC (Fat_Pointer,              S_AD);
  80    function From_AS  is new UC (Thin_Pointer,             S_AS);
  81    function From_F   is new UC (Float,                    S_F);
  82    function From_I   is new UC (Integer,                  S_I);
  83    function From_LF  is new UC (Long_Float,               S_LF);
  84    function From_LI  is new UC (Long_Integer,             S_LI);
  85    function From_LLF is new UC (Long_Long_Float,          S_LLF);
  86    function From_LLI is new UC (Long_Long_Integer,        S_LLI);
  87    function From_LLU is new UC (UST.Long_Long_Unsigned,   S_LLU);
  88    function From_LU  is new UC (UST.Long_Unsigned,        S_LU);
  89    function From_SF  is new UC (Short_Float,              S_SF);
  90    function From_SI  is new UC (Short_Integer,            S_SI);
  91    function From_SSI is new UC (Short_Short_Integer,      S_SSI);
  92    function From_SSU is new UC (UST.Short_Short_Unsigned, S_SSU);
  93    function From_SU  is new UC (UST.Short_Unsigned,       S_SU);
  94    function From_U   is new UC (UST.Unsigned,             S_U);
  95    function From_WC  is new UC (Wide_Character,           S_WC);
  96    function From_WWC is new UC (Wide_Wide_Character,      S_WWC);
  97
  98    --  Unchecked conversions from the stream type to elementary type
  99
 100    function To_AD  is new UC (S_AD,  Fat_Pointer);
 101    function To_AS  is new UC (S_AS,  Thin_Pointer);
 102    function To_F   is new UC (S_F,   Float);
 103    function To_I   is new UC (S_I,   Integer);
 104    function To_LF  is new UC (S_LF,  Long_Float);
 105    function To_LI  is new UC (S_LI,  Long_Integer);
 106    function To_LLF is new UC (S_LLF, Long_Long_Float);
 107    function To_LLI is new UC (S_LLI, Long_Long_Integer);
 108    function To_LLU is new UC (S_LLU, UST.Long_Long_Unsigned);
 109    function To_LU  is new UC (S_LU,  UST.Long_Unsigned);
 110    function To_SF  is new UC (S_SF,  Short_Float);
 111    function To_SI  is new UC (S_SI,  Short_Integer);
 112    function To_SSI is new UC (S_SSI, Short_Short_Integer);
 113    function To_SSU is new UC (S_SSU, UST.Short_Short_Unsigned);
 114    function To_SU  is new UC (S_SU,  UST.Short_Unsigned);
 115    function To_U   is new UC (S_U,   UST.Unsigned);
 116    function To_WC  is new UC (S_WC,  Wide_Character);
 117    function To_WWC is new UC (S_WWC, Wide_Wide_Character);
 118
 119    -----------------
 120    -- Block_IO_OK --
 121    -----------------
 122
 123    function Block_IO_OK return Boolean is
 124    begin
 125       return True;
 126    end Block_IO_OK;
 127
 128    ----------
 129    -- I_AD --
 130    ----------
 131
 132    function I_AD (Stream : not null access RST) return Fat_Pointer is
 133       T : S_AD;
 134       L : SEO;
 135
 136    begin
 137       Ada.Streams.Read (Stream.all, T, L);
 138
 139       if L < T'Last then
 140          raise Err;
 141       else
 142          return To_AD (T);
 143       end if;
 144    end I_AD;
 145
 146    ----------
 147    -- I_AS --
 148    ----------
 149
 150    function I_AS (Stream : not null access RST) return Thin_Pointer is
 151       T : S_AS;
 152       L : SEO;
 153
 154    begin
 155       Ada.Streams.Read (Stream.all, T, L);
 156
 157       if L < T'Last then
 158          raise Err;
 159       else
 160          return To_AS (T);
 161       end if;
 162    end I_AS;
 163
 164    ---------
 165    -- I_B --
 166    ---------
 167
 168    function I_B (Stream : not null access RST) return Boolean is
 169       T : S_B;
 170       L : SEO;
 171
 172    begin
 173       Ada.Streams.Read (Stream.all, T, L);
 174
 175       if L < T'Last then
 176          raise Err;
 177       else
 178          return Boolean'Val (T (1));
 179       end if;
 180    end I_B;
 181
 182    ---------
 183    -- I_C --
 184    ---------
 185
 186    function I_C (Stream : not null access RST) return Character is
 187       T : S_C;
 188       L : SEO;
 189
 190    begin
 191       Ada.Streams.Read (Stream.all, T, L);
 192
 193       if L < T'Last then
 194          raise Err;
 195       else
 196          return Character'Val (T (1));
 197       end if;
 198    end I_C;
 199
 200    ---------
 201    -- I_F --
 202    ---------
 203
 204    function I_F (Stream : not null access RST) return Float is
 205       T : S_F;
 206       L : SEO;
 207
 208    begin
 209       Ada.Streams.Read (Stream.all, T, L);
 210
 211       if L < T'Last then
 212          raise Err;
 213       else
 214          return To_F (T);
 215       end if;
 216    end I_F;
 217
 218    ---------
 219    -- I_I --
 220    ---------
 221
 222    function I_I (Stream : not null access RST) return Integer is
 223       T : S_I;
 224       L : SEO;
 225
 226    begin
 227       Ada.Streams.Read (Stream.all, T, L);
 228
 229       if L < T'Last then
 230          raise Err;
 231       else
 232          return To_I (T);
 233       end if;
 234    end I_I;
 235
 236    ----------
 237    -- I_LF --
 238    ----------
 239
 240    function I_LF (Stream : not null access RST) return Long_Float is
 241       T : S_LF;
 242       L : SEO;
 243
 244    begin
 245       Ada.Streams.Read (Stream.all, T, L);
 246
 247       if L < T'Last then
 248          raise Err;
 249       else
 250          return To_LF (T);
 251       end if;
 252    end I_LF;
 253
 254    ----------
 255    -- I_LI --
 256    ----------
 257
 258    function I_LI (Stream : not null access RST) return Long_Integer is
 259       T : S_LI;
 260       L : SEO;
 261
 262    begin
 263       Ada.Streams.Read (Stream.all, T, L);
 264
 265       if L < T'Last then
 266          raise Err;
 267       else
 268          return To_LI (T);
 269       end if;
 270    end I_LI;
 271
 272    -----------
 273    -- I_LLF --
 274    -----------
 275
 276    function I_LLF (Stream : not null access RST) return Long_Long_Float is
 277       T : S_LLF;
 278       L : SEO;
 279
 280    begin
 281       Ada.Streams.Read (Stream.all, T, L);
 282
 283       if L < T'Last then
 284          raise Err;
 285       else
 286          return To_LLF (T);
 287       end if;
 288    end I_LLF;
 289
 290    -----------
 291    -- I_LLI --
 292    -----------
 293
 294    function I_LLI (Stream : not null access RST) return Long_Long_Integer is
 295       T : S_LLI;
 296       L : SEO;
 297
 298    begin
 299       Ada.Streams.Read (Stream.all, T, L);
 300
 301       if L < T'Last then
 302          raise Err;
 303       else
 304          return To_LLI (T);
 305       end if;
 306    end I_LLI;
 307
 308    -----------
 309    -- I_LLU --
 310    -----------
 311
 312    function I_LLU
 313      (Stream : not null access RST) return UST.Long_Long_Unsigned
 314    is
 315       T : S_LLU;
 316       L : SEO;
 317
 318    begin
 319       Ada.Streams.Read (Stream.all, T, L);
 320
 321       if L < T'Last then
 322          raise Err;
 323       else
 324          return To_LLU (T);
 325       end if;
 326    end I_LLU;
 327
 328    ----------
 329    -- I_LU --
 330    ----------
 331
 332    function I_LU (Stream : not null access RST) return UST.Long_Unsigned is
 333       T : S_LU;
 334       L : SEO;
 335
 336    begin
 337       Ada.Streams.Read (Stream.all, T, L);
 338
 339       if L < T'Last then
 340          raise Err;
 341       else
 342          return To_LU (T);
 343       end if;
 344    end I_LU;
 345
 346    ----------
 347    -- I_SF --
 348    ----------
 349
 350    function I_SF (Stream : not null access RST) return Short_Float is
 351       T : S_SF;
 352       L : SEO;
 353
 354    begin
 355       Ada.Streams.Read (Stream.all, T, L);
 356
 357       if L < T'Last then
 358          raise Err;
 359       else
 360          return To_SF (T);
 361       end if;
 362    end I_SF;
 363
 364    ----------
 365    -- I_SI --
 366    ----------
 367
 368    function I_SI (Stream : not null access RST) return Short_Integer is
 369       T : S_SI;
 370       L : SEO;
 371
 372    begin
 373       Ada.Streams.Read (Stream.all, T, L);
 374
 375       if L < T'Last then
 376          raise Err;
 377       else
 378          return To_SI (T);
 379       end if;
 380    end I_SI;
 381
 382    -----------
 383    -- I_SSI --
 384    -----------
 385
 386    function I_SSI (Stream : not null access RST) return Short_Short_Integer is
 387       T : S_SSI;
 388       L : SEO;
 389
 390    begin
 391       Ada.Streams.Read (Stream.all, T, L);
 392
 393       if L < T'Last then
 394          raise Err;
 395       else
 396          return To_SSI (T);
 397       end if;
 398    end I_SSI;
 399
 400    -----------
 401    -- I_SSU --
 402    -----------
 403
 404    function I_SSU
 405      (Stream : not null access RST) return UST.Short_Short_Unsigned
 406    is
 407       T : S_SSU;
 408       L : SEO;
 409
 410    begin
 411       Ada.Streams.Read (Stream.all, T, L);
 412
 413       if L < T'Last then
 414          raise Err;
 415       else
 416          return To_SSU (T);
 417       end if;
 418    end I_SSU;
 419
 420    ----------
 421    -- I_SU --
 422    ----------
 423
 424    function I_SU (Stream : not null access RST) return UST.Short_Unsigned is
 425       T : S_SU;
 426       L : SEO;
 427
 428    begin
 429       Ada.Streams.Read (Stream.all, T, L);
 430
 431       if L < T'Last then
 432          raise Err;
 433       else
 434          return To_SU (T);
 435       end if;
 436    end I_SU;
 437
 438    ---------
 439    -- I_U --
 440    ---------
 441
 442    function I_U (Stream : not null access RST) return UST.Unsigned is
 443       T : S_U;
 444       L : SEO;
 445
 446    begin
 447       Ada.Streams.Read (Stream.all, T, L);
 448
 449       if L < T'Last then
 450          raise Err;
 451       else
 452          return To_U (T);
 453       end if;
 454    end I_U;
 455
 456    ----------
 457    -- I_WC --
 458    ----------
 459
 460    function I_WC (Stream : not null access RST) return Wide_Character is
 461       T : S_WC;
 462       L : SEO;
 463
 464    begin
 465       Ada.Streams.Read (Stream.all, T, L);
 466
 467       if L < T'Last then
 468          raise Err;
 469       else
 470          return To_WC (T);
 471       end if;
 472    end I_WC;
 473
 474    -----------
 475    -- I_WWC --
 476    -----------
 477
 478    function I_WWC (Stream : not null access RST) return Wide_Wide_Character is
 479       T : S_WWC;
 480       L : SEO;
 481
 482    begin
 483       Ada.Streams.Read (Stream.all, T, L);
 484
 485       if L < T'Last then
 486          raise Err;
 487       else
 488          return To_WWC (T);
 489       end if;
 490    end I_WWC;
 491
 492    ----------
 493    -- W_AD --
 494    ----------
 495
 496    procedure W_AD (Stream : not null access RST; Item : Fat_Pointer) is
 497       T : constant S_AD := From_AD (Item);
 498    begin
 499       Ada.Streams.Write (Stream.all, T);
 500    end W_AD;
 501
 502    ----------
 503    -- W_AS --
 504    ----------
 505
 506    procedure W_AS (Stream : not null access RST; Item : Thin_Pointer) is
 507       T : constant S_AS := From_AS (Item);
 508    begin
 509       Ada.Streams.Write (Stream.all, T);
 510    end W_AS;
 511
 512    ---------
 513    -- W_B --
 514    ---------
 515
 516    procedure W_B (Stream : not null access RST; Item : Boolean) is
 517       T : S_B;
 518    begin
 519       T (1) := Boolean'Pos (Item);
 520       Ada.Streams.Write (Stream.all, T);
 521    end W_B;
 522
 523    ---------
 524    -- W_C --
 525    ---------
 526
 527    procedure W_C (Stream : not null access RST; Item : Character) is
 528       T : S_C;
 529    begin
 530       T (1) := Character'Pos (Item);
 531       Ada.Streams.Write (Stream.all, T);
 532    end W_C;
 533
 534    ---------
 535    -- W_F --
 536    ---------
 537
 538    procedure W_F (Stream : not null access RST; Item : Float) is
 539       T : constant S_F := From_F (Item);
 540    begin
 541       Ada.Streams.Write (Stream.all, T);
 542    end W_F;
 543
 544    ---------
 545    -- W_I --
 546    ---------
 547
 548    procedure W_I (Stream : not null access RST; Item : Integer) is
 549       T : constant S_I := From_I (Item);
 550    begin
 551       Ada.Streams.Write (Stream.all, T);
 552    end W_I;
 553
 554    ----------
 555    -- W_LF --
 556    ----------
 557
 558    procedure W_LF (Stream : not null access RST; Item : Long_Float) is
 559       T : constant S_LF := From_LF (Item);
 560    begin
 561       Ada.Streams.Write (Stream.all, T);
 562    end W_LF;
 563
 564    ----------
 565    -- W_LI --
 566    ----------
 567
 568    procedure W_LI (Stream : not null access RST; Item : Long_Integer) is
 569       T : constant S_LI := From_LI (Item);
 570    begin
 571       Ada.Streams.Write (Stream.all, T);
 572    end W_LI;
 573
 574    -----------
 575    -- W_LLF --
 576    -----------
 577
 578    procedure W_LLF (Stream : not null access RST; Item : Long_Long_Float) is
 579       T : constant S_LLF := From_LLF (Item);
 580    begin
 581       Ada.Streams.Write (Stream.all, T);
 582    end W_LLF;
 583
 584    -----------
 585    -- W_LLI --
 586    -----------
 587
 588    procedure W_LLI
 589      (Stream : not null access RST; Item : Long_Long_Integer)
 590    is
 591       T : constant S_LLI := From_LLI (Item);
 592    begin
 593       Ada.Streams.Write (Stream.all, T);
 594    end W_LLI;
 595
 596    -----------
 597    -- W_LLU --
 598    -----------
 599
 600    procedure W_LLU
 601      (Stream : not null access RST; Item : UST.Long_Long_Unsigned)
 602    is
 603       T : constant S_LLU := From_LLU (Item);
 604    begin
 605       Ada.Streams.Write (Stream.all, T);
 606    end W_LLU;
 607
 608    ----------
 609    -- W_LU --
 610    ----------
 611
 612    procedure W_LU
 613      (Stream : not null access RST; Item : UST.Long_Unsigned)
 614    is
 615       T : constant S_LU := From_LU (Item);
 616    begin
 617       Ada.Streams.Write (Stream.all, T);
 618    end W_LU;
 619
 620    ----------
 621    -- W_SF --
 622    ----------
 623
 624    procedure W_SF (Stream : not null access RST; Item : Short_Float) is
 625       T : constant S_SF := From_SF (Item);
 626    begin
 627       Ada.Streams.Write (Stream.all, T);
 628    end W_SF;
 629
 630    ----------
 631    -- W_SI --
 632    ----------
 633
 634    procedure W_SI (Stream : not null access RST; Item : Short_Integer) is
 635       T : constant S_SI := From_SI (Item);
 636    begin
 637       Ada.Streams.Write (Stream.all, T);
 638    end W_SI;
 639
 640    -----------
 641    -- W_SSI --
 642    -----------
 643
 644    procedure W_SSI
 645      (Stream : not null access RST; Item : Short_Short_Integer)
 646    is
 647       T : constant S_SSI := From_SSI (Item);
 648    begin
 649       Ada.Streams.Write (Stream.all, T);
 650    end W_SSI;
 651
 652    -----------
 653    -- W_SSU --
 654    -----------
 655
 656    procedure W_SSU
 657      (Stream : not null access RST; Item : UST.Short_Short_Unsigned)
 658    is
 659       T : constant S_SSU := From_SSU (Item);
 660    begin
 661       Ada.Streams.Write (Stream.all, T);
 662    end W_SSU;
 663
 664    ----------
 665    -- W_SU --
 666    ----------
 667
 668    procedure W_SU
 669      (Stream : not null access RST; Item : UST.Short_Unsigned)
 670    is
 671       T : constant S_SU := From_SU (Item);
 672    begin
 673       Ada.Streams.Write (Stream.all, T);
 674    end W_SU;
 675
 676    ---------
 677    -- W_U --
 678    ---------
 679
 680    procedure W_U (Stream : not null access RST; Item : UST.Unsigned) is
 681       T : constant S_U := From_U (Item);
 682    begin
 683       Ada.Streams.Write (Stream.all, T);
 684    end W_U;
 685
 686    ----------
 687    -- W_WC --
 688    ----------
 689
 690    procedure W_WC (Stream : not null access RST; Item : Wide_Character) is
 691       T : constant S_WC := From_WC (Item);
 692    begin
 693       Ada.Streams.Write (Stream.all, T);
 694    end W_WC;
 695
 696    -----------
 697    -- W_WWC --
 698    -----------
 699
 700    procedure W_WWC
 701      (Stream : not null access RST; Item : Wide_Wide_Character)
 702    is
 703       T : constant S_WWC := From_WWC (Item);
 704    begin
 705       Ada.Streams.Write (Stream.all, T);
 706    end W_WWC;
 707
 708 end System.Stream_Attributes;