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