gcc/ada/s-auxdec.ads

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                       S Y S T E M . A U X _ D E C                        --
   6 --                                                                          --
   7 --                                 S p e c                                  --
   8 --                                                                          --
   9 --                            $Revision: 1.24 $
  10 --                                                                          --
  11 --          Copyright (C) 1996-2001 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS For A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNAT was originally developed  by the GNAT team at  New York University. --
  32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 --  This package contains definitions that are designed to be compatible
  37 --  with the extra definitions in package System for DEC Ada implementations.
  38
  39 --  These definitions can be used directly by withing this package, or merged
  40 --  with System using pragma Extend_System (Aux_DEC)
  41
  42 with Unchecked_Conversion;
  43
  44 package System.Aux_DEC is
  45 pragma Elaborate_Body (Aux_DEC);
  46
  47    type Integer_8  is range -2 **  (8 - 1) .. +2 **  (8 - 1) - 1;
  48    for Integer_8'Size  use  8;
  49
  50    type Integer_16 is range -2 ** (16 - 1) .. +2 ** (16 - 1) - 1;
  51    for Integer_16'Size use 16;
  52
  53    type Integer_32 is range -2 ** (32 - 1) .. +2 ** (32 - 1) - 1;
  54    for Integer_32'Size use 32;
  55
  56    type Integer_64 is range -2 ** (64 - 1) .. +2 ** (64 - 1) - 1;
  57    for Integer_64'Size use 64;
  58
  59    type Largest_Integer is range Min_Int .. Max_Int;
  60
  61    type AST_Handler is limited private;
  62
  63    No_AST_Handler : constant AST_Handler;
  64
  65    type Type_Class is
  66      (Type_Class_Enumeration,
  67       Type_Class_Integer,
  68       Type_Class_Fixed_Point,
  69       Type_Class_Floating_Point,
  70       Type_Class_Array,
  71       Type_Class_Record,
  72       Type_Class_Access,
  73       Type_Class_Task,             -- also in Ada 95 protected
  74       Type_Class_Address);
  75
  76    function "not" (Left        : Largest_Integer) return Largest_Integer;
  77    function "and" (Left, Right : Largest_Integer) return Largest_Integer;
  78    function "or"  (Left, Right : Largest_Integer) return Largest_Integer;
  79    function "xor" (Left, Right : Largest_Integer) return Largest_Integer;
  80
  81    Address_Zero : constant Address;
  82    No_Addr      : constant Address;
  83    Address_Size : constant := Standard'Address_Size;
  84
  85    function "+" (Left : Address; Right : Integer) return Address;
  86    function "+" (Left : Integer; Right : Address) return Address;
  87    function "-" (Left : Address; Right : Address) return Integer;
  88    function "-" (Left : Address; Right : Integer) return Address;
  89
  90    generic
  91       type Target is private;
  92    function Fetch_From_Address (A : Address) return Target;
  93
  94    generic
  95       type Target is private;
  96    procedure Assign_To_Address (A : Address; T : Target);
  97
  98    --  Floating point type declarations for VAX floating point data types
  99
 100    pragma Warnings (Off);
 101
 102    type F_Float is digits 6;
 103    pragma Float_Representation (VAX_Float, F_Float);
 104
 105    type D_Float is digits 9;
 106    pragma Float_Representation (Vax_Float, D_Float);
 107
 108    type G_Float is digits 15;
 109    pragma Float_Representation (Vax_Float, G_Float);
 110
 111    --  Floating point type declarations for IEEE floating point data types
 112
 113    type IEEE_Single_Float is digits 6;
 114    pragma Float_Representation (IEEE_Float, IEEE_Single_Float);
 115
 116    type IEEE_Double_Float is digits 15;
 117    pragma Float_Representation (IEEE_Float, IEEE_Double_Float);
 118
 119    pragma Warnings (On);
 120
 121    Non_Ada_Error : exception;
 122
 123    --  Hardware-oriented types and functions
 124
 125    type Bit_Array is array (Integer range <>) of Boolean;
 126    pragma Pack (Bit_Array);
 127
 128    subtype Bit_Array_8  is Bit_Array (0 ..  7);
 129    subtype Bit_Array_16 is Bit_Array (0 .. 15);
 130    subtype Bit_Array_32 is Bit_Array (0 .. 31);
 131    subtype Bit_Array_64 is Bit_Array (0 .. 63);
 132
 133    type Unsigned_Byte is range 0 .. 255;
 134    for  Unsigned_Byte'Size use 8;
 135
 136    function "not" (Left        : Unsigned_Byte) return Unsigned_Byte;
 137    function "and" (Left, Right : Unsigned_Byte) return Unsigned_Byte;
 138    function "or"  (Left, Right : Unsigned_Byte) return Unsigned_Byte;
 139    function "xor" (Left, Right : Unsigned_Byte) return Unsigned_Byte;
 140
 141    function To_Unsigned_Byte (X : Bit_Array_8) return Unsigned_Byte;
 142    function To_Bit_Array_8   (X : Unsigned_Byte) return Bit_Array_8;
 143
 144    type Unsigned_Byte_Array is array (Integer range <>) of Unsigned_Byte;
 145
 146    type Unsigned_Word is range 0 .. 65535;
 147    for  Unsigned_Word'Size use 16;
 148
 149    function "not" (Left        : Unsigned_Word) return Unsigned_Word;
 150    function "and" (Left, Right : Unsigned_Word) return Unsigned_Word;
 151    function "or"  (Left, Right : Unsigned_Word) return Unsigned_Word;
 152    function "xor" (Left, Right : Unsigned_Word) return Unsigned_Word;
 153
 154    function To_Unsigned_Word (X : Bit_Array_16) return Unsigned_Word;
 155    function To_Bit_Array_16  (X : Unsigned_Word) return Bit_Array_16;
 156
 157    type Unsigned_Word_Array is array (Integer range <>) of Unsigned_Word;
 158
 159    type Unsigned_Longword is range -2_147_483_648 .. 2_147_483_647;
 160    for  Unsigned_Longword'Size use 32;
 161
 162    function "not" (Left        : Unsigned_Longword) return Unsigned_Longword;
 163    function "and" (Left, Right : Unsigned_Longword) return Unsigned_Longword;
 164    function "or"  (Left, Right : Unsigned_Longword) return Unsigned_Longword;
 165    function "xor" (Left, Right : Unsigned_Longword) return Unsigned_Longword;
 166
 167    function To_Unsigned_Longword (X : Bit_Array_32) return Unsigned_Longword;
 168    function To_Bit_Array_32 (X : Unsigned_Longword) return Bit_Array_32;
 169
 170    type Unsigned_Longword_Array is
 171       array (Integer range <>) of Unsigned_Longword;
 172
 173    type Unsigned_32 is range 0 .. 4_294_967_295;
 174    for  Unsigned_32'Size use 32;
 175
 176    function "not" (Left        : Unsigned_32) return Unsigned_32;
 177    function "and" (Left, Right : Unsigned_32) return Unsigned_32;
 178    function "or"  (Left, Right : Unsigned_32) return Unsigned_32;
 179    function "xor" (Left, Right : Unsigned_32) return Unsigned_32;
 180
 181    function To_Unsigned_32 (X : Bit_Array_32) return Unsigned_32;
 182    function To_Bit_Array_32 (X : Unsigned_32) return Bit_Array_32;
 183
 184    type Unsigned_Quadword is record
 185       L0 : Unsigned_Longword;
 186       L1 : Unsigned_Longword;
 187    end record;
 188
 189    for Unsigned_Quadword'Size      use 64;
 190    for Unsigned_Quadword'Alignment use
 191      Integer'Min (8, Standard'Maximum_Alignment);
 192
 193    function "not" (Left        : Unsigned_Quadword) return Unsigned_Quadword;
 194    function "and" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword;
 195    function "or"  (Left, Right : Unsigned_Quadword) return Unsigned_Quadword;
 196    function "xor" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword;
 197
 198    function To_Unsigned_Quadword (X : Bit_Array_64) return Unsigned_Quadword;
 199    function To_Bit_Array_64 (X : Unsigned_Quadword) return Bit_Array_64;
 200
 201    type Unsigned_Quadword_Array is
 202       array (Integer range <>) of Unsigned_Quadword;
 203
 204    function To_Address      (X : Integer)           return Address;
 205    pragma Pure_Function (To_Address);
 206
 207    function To_Address_Long (X : Unsigned_Longword) return Address;
 208    pragma Pure_Function (To_Address_Long);
 209
 210    function To_Integer      (X : Address)           return Integer;
 211
 212    function To_Unsigned_Longword (X : Address)     return Unsigned_Longword;
 213    function To_Unsigned_Longword (X : AST_Handler) return Unsigned_Longword;
 214
 215    --  Conventional names for static subtypes of type UNSIGNED_LONGWORD
 216
 217    subtype Unsigned_1  is Unsigned_Longword range 0 .. 2** 1-1;
 218    subtype Unsigned_2  is Unsigned_Longword range 0 .. 2** 2-1;
 219    subtype Unsigned_3  is Unsigned_Longword range 0 .. 2** 3-1;
 220    subtype Unsigned_4  is Unsigned_Longword range 0 .. 2** 4-1;
 221    subtype Unsigned_5  is Unsigned_Longword range 0 .. 2** 5-1;
 222    subtype Unsigned_6  is Unsigned_Longword range 0 .. 2** 6-1;
 223    subtype Unsigned_7  is Unsigned_Longword range 0 .. 2** 7-1;
 224    subtype Unsigned_8  is Unsigned_Longword range 0 .. 2** 8-1;
 225    subtype Unsigned_9  is Unsigned_Longword range 0 .. 2** 9-1;
 226    subtype Unsigned_10 is Unsigned_Longword range 0 .. 2**10-1;
 227    subtype Unsigned_11 is Unsigned_Longword range 0 .. 2**11-1;
 228    subtype Unsigned_12 is Unsigned_Longword range 0 .. 2**12-1;
 229    subtype Unsigned_13 is Unsigned_Longword range 0 .. 2**13-1;
 230    subtype Unsigned_14 is Unsigned_Longword range 0 .. 2**14-1;
 231    subtype Unsigned_15 is Unsigned_Longword range 0 .. 2**15-1;
 232    subtype Unsigned_16 is Unsigned_Longword range 0 .. 2**16-1;
 233    subtype Unsigned_17 is Unsigned_Longword range 0 .. 2**17-1;
 234    subtype Unsigned_18 is Unsigned_Longword range 0 .. 2**18-1;
 235    subtype Unsigned_19 is Unsigned_Longword range 0 .. 2**19-1;
 236    subtype Unsigned_20 is Unsigned_Longword range 0 .. 2**20-1;
 237    subtype Unsigned_21 is Unsigned_Longword range 0 .. 2**21-1;
 238    subtype Unsigned_22 is Unsigned_Longword range 0 .. 2**22-1;
 239    subtype Unsigned_23 is Unsigned_Longword range 0 .. 2**23-1;
 240    subtype Unsigned_24 is Unsigned_Longword range 0 .. 2**24-1;
 241    subtype Unsigned_25 is Unsigned_Longword range 0 .. 2**25-1;
 242    subtype Unsigned_26 is Unsigned_Longword range 0 .. 2**26-1;
 243    subtype Unsigned_27 is Unsigned_Longword range 0 .. 2**27-1;
 244    subtype Unsigned_28 is Unsigned_Longword range 0 .. 2**28-1;
 245    subtype Unsigned_29 is Unsigned_Longword range 0 .. 2**29-1;
 246    subtype Unsigned_30 is Unsigned_Longword range 0 .. 2**30-1;
 247    subtype Unsigned_31 is Unsigned_Longword range 0 .. 2**31-1;
 248
 249    --  Function for obtaining global symbol values
 250
 251    function Import_Value         (Symbol : String) return Unsigned_Longword;
 252    function Import_Address       (Symbol : String) return Address;
 253    function Import_Largest_Value (Symbol : String) return Largest_Integer;
 254
 255    pragma Import (Intrinsic, Import_Value);
 256    pragma Import (Intrinsic, Import_Address);
 257    pragma Import (Intrinsic, Import_Largest_Value);
 258
 259    --  For the following declarations, note that the declaration without
 260    --  a Retry_Count parameter means to retry infinitely. A value of zero
 261    --  for the Retry_Count parameter means do not retry.
 262
 263    --  Interlocked-instruction procedures
 264
 265    procedure Clear_Interlocked
 266      (Bit       : in out Boolean;
 267       Old_Value : out Boolean);
 268
 269    procedure Set_Interlocked
 270      (Bit       : in out Boolean;
 271       Old_Value : out Boolean);
 272
 273    type Aligned_Word is record
 274       Value : Short_Integer;
 275    end record;
 276
 277    for Aligned_Word'Alignment use
 278      Integer'Min (2, Standard'Maximum_Alignment);
 279
 280    procedure Clear_Interlocked
 281      (Bit          : in out Boolean;
 282       Old_Value    : out Boolean;
 283       Retry_Count  : in Natural;
 284       Success_Flag : out Boolean);
 285
 286    procedure Set_Interlocked
 287      (Bit          : in out Boolean;
 288       Old_Value    : out Boolean;
 289       Retry_Count  : in Natural;
 290       Success_Flag : out Boolean);
 291
 292    procedure Add_Interlocked
 293      (Addend       : in Short_Integer;
 294       Augend       : in out Aligned_Word;
 295       Sign         : out Integer);
 296
 297    type Aligned_Integer is record
 298       Value : Integer;
 299    end record;
 300
 301    for Aligned_Integer'Alignment use
 302      Integer'Min (4, Standard'Maximum_Alignment);
 303
 304    type Aligned_Long_Integer is record
 305       Value : Long_Integer;
 306    end record;
 307
 308    for Aligned_Long_Integer'Alignment use
 309      Integer'Min (8, Standard'Maximum_Alignment);
 310
 311    --  For the following declarations, note that the declaration without
 312    --  a Retry_Count parameter mean to retry infinitely. A value of zero
 313    --  for the Retry_Count means do not retry.
 314
 315    procedure Add_Atomic
 316      (To           : in out Aligned_Integer;
 317       Amount       : in Integer);
 318
 319    procedure Add_Atomic
 320      (To           : in out Aligned_Integer;
 321       Amount       : in Integer;
 322       Retry_Count  : in Natural;
 323       Old_Value    : out Integer;
 324       Success_Flag : out Boolean);
 325
 326    procedure Add_Atomic
 327      (To           : in out Aligned_Long_Integer;
 328       Amount       : in Long_Integer);
 329
 330    procedure Add_Atomic
 331      (To           : in out Aligned_Long_Integer;
 332       Amount       : in Long_Integer;
 333       Retry_Count  : in Natural;
 334       Old_Value    : out Long_Integer;
 335       Success_Flag : out Boolean);
 336
 337    procedure And_Atomic
 338      (To           : in out Aligned_Integer;
 339       From         : in Integer);
 340
 341    procedure And_Atomic
 342      (To           : in out Aligned_Integer;
 343       From         : in Integer;
 344       Retry_Count  : in Natural;
 345       Old_Value    : out Integer;
 346       Success_Flag : out Boolean);
 347
 348    procedure And_Atomic
 349      (To           : in out Aligned_Long_Integer;
 350       From         : in Long_Integer);
 351
 352    procedure And_Atomic
 353      (To           : in out Aligned_Long_Integer;
 354       From         : in Long_Integer;
 355       Retry_Count  : in Natural;
 356       Old_Value    : out Long_Integer;
 357       Success_Flag : out Boolean);
 358
 359    procedure Or_Atomic
 360      (To           : in out Aligned_Integer;
 361       From         : in Integer);
 362
 363    procedure Or_Atomic
 364      (To           : in out Aligned_Integer;
 365       From         : in Integer;
 366       Retry_Count  : in Natural;
 367       Old_Value    : out Integer;
 368       Success_Flag : out Boolean);
 369
 370    procedure Or_Atomic
 371      (To           : in out Aligned_Long_Integer;
 372       From         : in Long_Integer);
 373
 374    procedure Or_Atomic
 375      (To           : in out Aligned_Long_Integer;
 376       From         : in Long_Integer;
 377       Retry_Count  : in Natural;
 378       Old_Value    : out Long_Integer;
 379       Success_Flag : out Boolean);
 380
 381    type Insq_Status is
 382      (Fail_No_Lock, OK_Not_First, OK_First);
 383
 384    for Insq_Status use
 385      (Fail_No_Lock => -1,
 386       OK_Not_First => 0,
 387       OK_First     => +1);
 388
 389    type Remq_Status is (
 390      Fail_No_Lock,
 391      Fail_Was_Empty,
 392      OK_Not_Empty,
 393      OK_Empty);
 394
 395    for Remq_Status use
 396      (Fail_No_Lock   => -1,
 397       Fail_Was_Empty => 0,
 398       OK_Not_Empty   => +1,
 399       OK_Empty       => +2);
 400
 401    procedure Insqhi
 402      (Item   : in  Address;
 403       Header : in  Address;
 404       Status : out Insq_Status);
 405
 406    procedure Remqhi
 407      (Header : in  Address;
 408       Item   : out Address;
 409       Status : out Remq_Status);
 410
 411    procedure Insqti
 412      (Item   : in  Address;
 413       Header : in  Address;
 414       Status : out Insq_Status);
 415
 416    procedure Remqti
 417      (Header : in  Address;
 418       Item   : out Address;
 419       Status : out Remq_Status);
 420
 421 private
 422
 423    Address_Zero : constant Address := Null_Address;
 424    No_Addr      : constant Address := Null_Address;
 425
 426    --  An AST_Handler value is from a typing point of view simply a pointer
 427    --  to a procedure taking a single 64bit parameter. However, this
 428    --  is a bit misleading, because the data that this pointer references is
 429    --  highly stylized. See body of System.AST_Handling for full details.
 430
 431    type AST_Handler is access procedure (Param : Long_Integer);
 432    No_AST_Handler : constant AST_Handler := null;
 433
 434    --  Other operators have incorrect profiles. It would be nice to make
 435    --  them intrinsic, since the backend can handle them, but the front
 436    --  end is not prepared to deal with them, so at least inline them.
 437
 438    pragma Inline ("+");
 439    pragma Inline ("-");
 440    pragma Inline ("not");
 441    pragma Inline ("and");
 442    pragma Inline ("or");
 443    pragma Inline ("xor");
 444
 445    --  Other inlined subprograms
 446
 447    pragma Inline (Fetch_From_Address);
 448    pragma Inline (Assign_To_Address);
 449
 450    --  Provide proper unchecked conversion definitions for transfer
 451    --  functions. Note that we need this level of indirection because
 452    --  the formal parameter name is X and not Source (and this is indeed
 453    --  detectable by a program)
 454
 455    function To_Unsigned_Byte_A is new
 456      Unchecked_Conversion (Bit_Array_8, Unsigned_Byte);
 457
 458    function To_Unsigned_Byte (X : Bit_Array_8) return Unsigned_Byte
 459      renames To_Unsigned_Byte_A;
 460
 461    function To_Bit_Array_8_A is new
 462      Unchecked_Conversion (Unsigned_Byte, Bit_Array_8);
 463
 464    function To_Bit_Array_8 (X : Unsigned_Byte) return Bit_Array_8
 465      renames To_Bit_Array_8_A;
 466
 467    function To_Unsigned_Word_A is new
 468      Unchecked_Conversion (Bit_Array_16, Unsigned_Word);
 469
 470    function To_Unsigned_Word (X : Bit_Array_16) return Unsigned_Word
 471      renames To_Unsigned_Word_A;
 472
 473    function To_Bit_Array_16_A is new
 474      Unchecked_Conversion (Unsigned_Word, Bit_Array_16);
 475
 476    function To_Bit_Array_16 (X : Unsigned_Word) return Bit_Array_16
 477      renames To_Bit_Array_16_A;
 478
 479    function To_Unsigned_Longword_A is new
 480      Unchecked_Conversion (Bit_Array_32, Unsigned_Longword);
 481
 482    function To_Unsigned_Longword (X : Bit_Array_32) return Unsigned_Longword
 483      renames To_Unsigned_Longword_A;
 484
 485    function To_Bit_Array_32_A is new
 486      Unchecked_Conversion (Unsigned_Longword, Bit_Array_32);
 487
 488    function To_Bit_Array_32 (X : Unsigned_Longword) return Bit_Array_32
 489      renames To_Bit_Array_32_A;
 490
 491    function To_Unsigned_32_A is new
 492      Unchecked_Conversion (Bit_Array_32, Unsigned_32);
 493
 494    function To_Unsigned_32 (X : Bit_Array_32) return Unsigned_32
 495      renames To_Unsigned_32_A;
 496
 497    function To_Bit_Array_32_A is new
 498      Unchecked_Conversion (Unsigned_32, Bit_Array_32);
 499
 500    function To_Bit_Array_32 (X : Unsigned_32) return Bit_Array_32
 501      renames To_Bit_Array_32_A;
 502
 503    function To_Unsigned_Quadword_A is new
 504      Unchecked_Conversion (Bit_Array_64, Unsigned_Quadword);
 505
 506    function To_Unsigned_Quadword (X : Bit_Array_64) return Unsigned_Quadword
 507      renames To_Unsigned_Quadword_A;
 508
 509    function To_Bit_Array_64_A is new
 510      Unchecked_Conversion (Unsigned_Quadword, Bit_Array_64);
 511
 512    function To_Bit_Array_64 (X : Unsigned_Quadword) return Bit_Array_64
 513      renames To_Bit_Array_64_A;
 514
 515    pragma Warnings (Off);
 516    --  Turn warnings off. This is needed for systems with 64-bit integers,
 517    --  where some of these operations are of dubious meaning, but we do not
 518    --  want warnings when we compile on such systems.
 519
 520    function To_Address_A is new
 521      Unchecked_Conversion (Integer, Address);
 522    pragma Pure_Function (To_Address_A);
 523
 524    function To_Address (X : Integer) return Address
 525      renames To_Address_A;
 526    pragma Pure_Function (To_Address);
 527
 528    function To_Address_Long_A is new
 529      Unchecked_Conversion (Unsigned_Longword, Address);
 530    pragma Pure_Function (To_Address_Long_A);
 531
 532    function To_Address_Long (X : Unsigned_Longword) return Address
 533      renames To_Address_Long_A;
 534    pragma Pure_Function (To_Address_Long);
 535
 536    function To_Integer_A is new
 537      Unchecked_Conversion (Address, Integer);
 538
 539    function To_Integer (X : Address) return Integer
 540      renames To_Integer_A;
 541
 542    function To_Unsigned_Longword_A is new
 543      Unchecked_Conversion (Address, Unsigned_Longword);
 544
 545    function To_Unsigned_Longword (X : Address) return Unsigned_Longword
 546      renames To_Unsigned_Longword_A;
 547
 548    function To_Unsigned_Longword_A is new
 549      Unchecked_Conversion (AST_Handler, Unsigned_Longword);
 550
 551    function To_Unsigned_Longword (X : AST_Handler) return Unsigned_Longword
 552      renames To_Unsigned_Longword_A;
 553
 554    pragma Warnings (On);
 555
 556 end System.Aux_DEC;