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