gcc/ada/s-stratt.adb

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