diff options
Diffstat (limited to 'gcc-4.4.3/gcc/ada/s-auxdec.adb')
-rw-r--r-- | gcc-4.4.3/gcc/ada/s-auxdec.adb | 718 |
1 files changed, 0 insertions, 718 deletions
diff --git a/gcc-4.4.3/gcc/ada/s-auxdec.adb b/gcc-4.4.3/gcc/ada/s-auxdec.adb deleted file mode 100644 index bfb489477..000000000 --- a/gcc-4.4.3/gcc/ada/s-auxdec.adb +++ /dev/null @@ -1,718 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . A U X _ D E C -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/Or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Style_Checks (All_Checks); --- Turn off alpha ordering check on subprograms, this unit is laid --- out to correspond to the declarations in the DEC 83 System unit. - -with System.Soft_Links; - -package body System.Aux_DEC is - - package SSL renames System.Soft_Links; - - ----------------------------------- - -- Operations on Largest_Integer -- - ----------------------------------- - - -- It would be nice to replace these with intrinsics, but that does - -- not work yet (the back end would be ok, but GNAT itself objects) - - type LIU is mod 2 ** Largest_Integer'Size; - -- Unsigned type of same length as Largest_Integer - - function To_LI is new Ada.Unchecked_Conversion (LIU, Largest_Integer); - function From_LI is new Ada.Unchecked_Conversion (Largest_Integer, LIU); - - function "not" (Left : Largest_Integer) return Largest_Integer is - begin - return To_LI (not From_LI (Left)); - end "not"; - - function "and" (Left, Right : Largest_Integer) return Largest_Integer is - begin - return To_LI (From_LI (Left) and From_LI (Right)); - end "and"; - - function "or" (Left, Right : Largest_Integer) return Largest_Integer is - begin - return To_LI (From_LI (Left) or From_LI (Right)); - end "or"; - - function "xor" (Left, Right : Largest_Integer) return Largest_Integer is - begin - return To_LI (From_LI (Left) xor From_LI (Right)); - end "xor"; - - -------------------------------------- - -- Arithmetic Operations on Address -- - -------------------------------------- - - -- It would be nice to replace these with intrinsics, but that does - -- not work yet (the back end would be ok, but GNAT itself objects) - - Asiz : constant Integer := Integer (Address'Size) - 1; - - type SA is range -(2 ** Asiz) .. 2 ** Asiz - 1; - -- Signed type of same size as Address - - function To_A is new Ada.Unchecked_Conversion (SA, Address); - function From_A is new Ada.Unchecked_Conversion (Address, SA); - - function "+" (Left : Address; Right : Integer) return Address is - begin - return To_A (From_A (Left) + SA (Right)); - end "+"; - - function "+" (Left : Integer; Right : Address) return Address is - begin - return To_A (SA (Left) + From_A (Right)); - end "+"; - - function "-" (Left : Address; Right : Address) return Integer is - pragma Unsuppress (All_Checks); - -- Because this can raise Constraint_Error for 64-bit addresses - begin - return Integer (From_A (Left) - From_A (Right)); - end "-"; - - function "-" (Left : Address; Right : Integer) return Address is - begin - return To_A (From_A (Left) - SA (Right)); - end "-"; - - ------------------------ - -- Fetch_From_Address -- - ------------------------ - - function Fetch_From_Address (A : Address) return Target is - type T_Ptr is access all Target; - function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr); - Ptr : constant T_Ptr := To_T_Ptr (A); - begin - return Ptr.all; - end Fetch_From_Address; - - ----------------------- - -- Assign_To_Address -- - ----------------------- - - procedure Assign_To_Address (A : Address; T : Target) is - type T_Ptr is access all Target; - function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr); - Ptr : constant T_Ptr := To_T_Ptr (A); - begin - Ptr.all := T; - end Assign_To_Address; - - --------------------------------- - -- Operations on Unsigned_Byte -- - --------------------------------- - - -- It would be nice to replace these with intrinsics, but that does - -- not work yet (the back end would be ok, but GNAT itself objects) - - type BU is mod 2 ** Unsigned_Byte'Size; - -- Unsigned type of same length as Unsigned_Byte - - function To_B is new Ada.Unchecked_Conversion (BU, Unsigned_Byte); - function From_B is new Ada.Unchecked_Conversion (Unsigned_Byte, BU); - - function "not" (Left : Unsigned_Byte) return Unsigned_Byte is - begin - return To_B (not From_B (Left)); - end "not"; - - function "and" (Left, Right : Unsigned_Byte) return Unsigned_Byte is - begin - return To_B (From_B (Left) and From_B (Right)); - end "and"; - - function "or" (Left, Right : Unsigned_Byte) return Unsigned_Byte is - begin - return To_B (From_B (Left) or From_B (Right)); - end "or"; - - function "xor" (Left, Right : Unsigned_Byte) return Unsigned_Byte is - begin - return To_B (From_B (Left) xor From_B (Right)); - end "xor"; - - --------------------------------- - -- Operations on Unsigned_Word -- - --------------------------------- - - -- It would be nice to replace these with intrinsics, but that does - -- not work yet (the back end would be ok, but GNAT itself objects) - - type WU is mod 2 ** Unsigned_Word'Size; - -- Unsigned type of same length as Unsigned_Word - - function To_W is new Ada.Unchecked_Conversion (WU, Unsigned_Word); - function From_W is new Ada.Unchecked_Conversion (Unsigned_Word, WU); - - function "not" (Left : Unsigned_Word) return Unsigned_Word is - begin - return To_W (not From_W (Left)); - end "not"; - - function "and" (Left, Right : Unsigned_Word) return Unsigned_Word is - begin - return To_W (From_W (Left) and From_W (Right)); - end "and"; - - function "or" (Left, Right : Unsigned_Word) return Unsigned_Word is - begin - return To_W (From_W (Left) or From_W (Right)); - end "or"; - - function "xor" (Left, Right : Unsigned_Word) return Unsigned_Word is - begin - return To_W (From_W (Left) xor From_W (Right)); - end "xor"; - - ------------------------------------- - -- Operations on Unsigned_Longword -- - ------------------------------------- - - -- It would be nice to replace these with intrinsics, but that does - -- not work yet (the back end would be ok, but GNAT itself objects) - - type LWU is mod 2 ** Unsigned_Longword'Size; - -- Unsigned type of same length as Unsigned_Longword - - function To_LW is new Ada.Unchecked_Conversion (LWU, Unsigned_Longword); - function From_LW is new Ada.Unchecked_Conversion (Unsigned_Longword, LWU); - - function "not" (Left : Unsigned_Longword) return Unsigned_Longword is - begin - return To_LW (not From_LW (Left)); - end "not"; - - function "and" (Left, Right : Unsigned_Longword) return Unsigned_Longword is - begin - return To_LW (From_LW (Left) and From_LW (Right)); - end "and"; - - function "or" (Left, Right : Unsigned_Longword) return Unsigned_Longword is - begin - return To_LW (From_LW (Left) or From_LW (Right)); - end "or"; - - function "xor" (Left, Right : Unsigned_Longword) return Unsigned_Longword is - begin - return To_LW (From_LW (Left) xor From_LW (Right)); - end "xor"; - - ------------------------------- - -- Operations on Unsigned_32 -- - ------------------------------- - - -- It would be nice to replace these with intrinsics, but that does - -- not work yet (the back end would be ok, but GNAT itself objects) - - type U32 is mod 2 ** Unsigned_32'Size; - -- Unsigned type of same length as Unsigned_32 - - function To_U32 is new Ada.Unchecked_Conversion (U32, Unsigned_32); - function From_U32 is new Ada.Unchecked_Conversion (Unsigned_32, U32); - - function "not" (Left : Unsigned_32) return Unsigned_32 is - begin - return To_U32 (not From_U32 (Left)); - end "not"; - - function "and" (Left, Right : Unsigned_32) return Unsigned_32 is - begin - return To_U32 (From_U32 (Left) and From_U32 (Right)); - end "and"; - - function "or" (Left, Right : Unsigned_32) return Unsigned_32 is - begin - return To_U32 (From_U32 (Left) or From_U32 (Right)); - end "or"; - - function "xor" (Left, Right : Unsigned_32) return Unsigned_32 is - begin - return To_U32 (From_U32 (Left) xor From_U32 (Right)); - end "xor"; - - ------------------------------------- - -- Operations on Unsigned_Quadword -- - ------------------------------------- - - -- It would be nice to replace these with intrinsics, but that does - -- not work yet (the back end would be ok, but GNAT itself objects) - - type QWU is mod 2 ** 64; -- 64 = Unsigned_Quadword'Size - -- Unsigned type of same length as Unsigned_Quadword - - function To_QW is new Ada.Unchecked_Conversion (QWU, Unsigned_Quadword); - function From_QW is new Ada.Unchecked_Conversion (Unsigned_Quadword, QWU); - - function "not" (Left : Unsigned_Quadword) return Unsigned_Quadword is - begin - return To_QW (not From_QW (Left)); - end "not"; - - function "and" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is - begin - return To_QW (From_QW (Left) and From_QW (Right)); - end "and"; - - function "or" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is - begin - return To_QW (From_QW (Left) or From_QW (Right)); - end "or"; - - function "xor" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is - begin - return To_QW (From_QW (Left) xor From_QW (Right)); - end "xor"; - - ----------------------- - -- Clear_Interlocked -- - ----------------------- - - procedure Clear_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean) - is - begin - SSL.Lock_Task.all; - Old_Value := Bit; - Bit := False; - SSL.Unlock_Task.all; - end Clear_Interlocked; - - procedure Clear_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean; - Retry_Count : Natural; - Success_Flag : out Boolean) - is - pragma Warnings (Off, Retry_Count); - - begin - SSL.Lock_Task.all; - Old_Value := Bit; - Bit := False; - Success_Flag := True; - SSL.Unlock_Task.all; - end Clear_Interlocked; - - --------------------- - -- Set_Interlocked -- - --------------------- - - procedure Set_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean) - is - begin - SSL.Lock_Task.all; - Old_Value := Bit; - Bit := True; - SSL.Unlock_Task.all; - end Set_Interlocked; - - procedure Set_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean; - Retry_Count : Natural; - Success_Flag : out Boolean) - is - pragma Warnings (Off, Retry_Count); - - begin - SSL.Lock_Task.all; - Old_Value := Bit; - Bit := True; - Success_Flag := True; - SSL.Unlock_Task.all; - end Set_Interlocked; - - --------------------- - -- Add_Interlocked -- - --------------------- - - procedure Add_Interlocked - (Addend : Short_Integer; - Augend : in out Aligned_Word; - Sign : out Integer) - is - begin - SSL.Lock_Task.all; - Augend.Value := Augend.Value + Addend; - - if Augend.Value < 0 then - Sign := -1; - elsif Augend.Value > 0 then - Sign := +1; - else - Sign := 0; - end if; - - SSL.Unlock_Task.all; - end Add_Interlocked; - - ---------------- - -- Add_Atomic -- - ---------------- - - procedure Add_Atomic - (To : in out Aligned_Integer; - Amount : Integer) - is - begin - SSL.Lock_Task.all; - To.Value := To.Value + Amount; - SSL.Unlock_Task.all; - end Add_Atomic; - - procedure Add_Atomic - (To : in out Aligned_Integer; - Amount : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean) - is - pragma Warnings (Off, Retry_Count); - - begin - SSL.Lock_Task.all; - Old_Value := To.Value; - To.Value := To.Value + Amount; - Success_Flag := True; - SSL.Unlock_Task.all; - end Add_Atomic; - - procedure Add_Atomic - (To : in out Aligned_Long_Integer; - Amount : Long_Integer) - is - begin - SSL.Lock_Task.all; - To.Value := To.Value + Amount; - SSL.Unlock_Task.all; - end Add_Atomic; - - procedure Add_Atomic - (To : in out Aligned_Long_Integer; - Amount : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean) - is - pragma Warnings (Off, Retry_Count); - - begin - SSL.Lock_Task.all; - Old_Value := To.Value; - To.Value := To.Value + Amount; - Success_Flag := True; - SSL.Unlock_Task.all; - end Add_Atomic; - - ---------------- - -- And_Atomic -- - ---------------- - - type IU is mod 2 ** Integer'Size; - type LU is mod 2 ** Long_Integer'Size; - - function To_IU is new Ada.Unchecked_Conversion (Integer, IU); - function From_IU is new Ada.Unchecked_Conversion (IU, Integer); - - function To_LU is new Ada.Unchecked_Conversion (Long_Integer, LU); - function From_LU is new Ada.Unchecked_Conversion (LU, Long_Integer); - - procedure And_Atomic - (To : in out Aligned_Integer; - From : Integer) - is - begin - SSL.Lock_Task.all; - To.Value := From_IU (To_IU (To.Value) and To_IU (From)); - SSL.Unlock_Task.all; - end And_Atomic; - - procedure And_Atomic - (To : in out Aligned_Integer; - From : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean) - is - pragma Warnings (Off, Retry_Count); - - begin - SSL.Lock_Task.all; - Old_Value := To.Value; - To.Value := From_IU (To_IU (To.Value) and To_IU (From)); - Success_Flag := True; - SSL.Unlock_Task.all; - end And_Atomic; - - procedure And_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer) - is - begin - SSL.Lock_Task.all; - To.Value := From_LU (To_LU (To.Value) and To_LU (From)); - SSL.Unlock_Task.all; - end And_Atomic; - - procedure And_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean) - is - pragma Warnings (Off, Retry_Count); - - begin - SSL.Lock_Task.all; - Old_Value := To.Value; - To.Value := From_LU (To_LU (To.Value) and To_LU (From)); - Success_Flag := True; - SSL.Unlock_Task.all; - end And_Atomic; - - --------------- - -- Or_Atomic -- - --------------- - - procedure Or_Atomic - (To : in out Aligned_Integer; - From : Integer) - is - begin - SSL.Lock_Task.all; - To.Value := From_IU (To_IU (To.Value) or To_IU (From)); - SSL.Unlock_Task.all; - end Or_Atomic; - - procedure Or_Atomic - (To : in out Aligned_Integer; - From : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean) - is - pragma Warnings (Off, Retry_Count); - - begin - SSL.Lock_Task.all; - Old_Value := To.Value; - To.Value := From_IU (To_IU (To.Value) or To_IU (From)); - Success_Flag := True; - SSL.Unlock_Task.all; - end Or_Atomic; - - procedure Or_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer) - is - begin - SSL.Lock_Task.all; - To.Value := From_LU (To_LU (To.Value) or To_LU (From)); - SSL.Unlock_Task.all; - end Or_Atomic; - - procedure Or_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean) - is - pragma Warnings (Off, Retry_Count); - - begin - SSL.Lock_Task.all; - Old_Value := To.Value; - To.Value := From_LU (To_LU (To.Value) or To_LU (From)); - Success_Flag := True; - SSL.Unlock_Task.all; - end Or_Atomic; - - ------------------------------------ - -- Declarations for Queue Objects -- - ------------------------------------ - - type QR; - - type QR_Ptr is access QR; - - type QR is record - Forward : QR_Ptr; - Backward : QR_Ptr; - end record; - - function To_QR_Ptr is new Ada.Unchecked_Conversion (Address, QR_Ptr); - function From_QR_Ptr is new Ada.Unchecked_Conversion (QR_Ptr, Address); - - ------------ - -- Insqhi -- - ------------ - - procedure Insqhi - (Item : Address; - Header : Address; - Status : out Insq_Status) - is - Hedr : constant QR_Ptr := To_QR_Ptr (Header); - Next : constant QR_Ptr := Hedr.Forward; - Itm : constant QR_Ptr := To_QR_Ptr (Item); - - begin - SSL.Lock_Task.all; - - Itm.Forward := Next; - Itm.Backward := Hedr; - Hedr.Forward := Itm; - - if Next = null then - Status := OK_First; - - else - Next.Backward := Itm; - Status := OK_Not_First; - end if; - - SSL.Unlock_Task.all; - end Insqhi; - - ------------ - -- Remqhi -- - ------------ - - procedure Remqhi - (Header : Address; - Item : out Address; - Status : out Remq_Status) - is - Hedr : constant QR_Ptr := To_QR_Ptr (Header); - Next : constant QR_Ptr := Hedr.Forward; - - begin - SSL.Lock_Task.all; - - Item := From_QR_Ptr (Next); - - if Next = null then - Status := Fail_Was_Empty; - - else - Hedr.Forward := To_QR_Ptr (Item).Forward; - - if Hedr.Forward = null then - Status := OK_Empty; - - else - Hedr.Forward.Backward := Hedr; - Status := OK_Not_Empty; - end if; - end if; - - SSL.Unlock_Task.all; - end Remqhi; - - ------------ - -- Insqti -- - ------------ - - procedure Insqti - (Item : Address; - Header : Address; - Status : out Insq_Status) - is - Hedr : constant QR_Ptr := To_QR_Ptr (Header); - Prev : constant QR_Ptr := Hedr.Backward; - Itm : constant QR_Ptr := To_QR_Ptr (Item); - - begin - SSL.Lock_Task.all; - - Itm.Backward := Prev; - Itm.Forward := Hedr; - Hedr.Backward := Itm; - - if Prev = null then - Status := OK_First; - - else - Prev.Forward := Itm; - Status := OK_Not_First; - end if; - - SSL.Unlock_Task.all; - end Insqti; - - ------------ - -- Remqti -- - ------------ - - procedure Remqti - (Header : Address; - Item : out Address; - Status : out Remq_Status) - is - Hedr : constant QR_Ptr := To_QR_Ptr (Header); - Prev : constant QR_Ptr := Hedr.Backward; - - begin - SSL.Lock_Task.all; - - Item := From_QR_Ptr (Prev); - - if Prev = null then - Status := Fail_Was_Empty; - - else - Hedr.Backward := To_QR_Ptr (Item).Backward; - - if Hedr.Backward = null then - Status := OK_Empty; - - else - Hedr.Backward.Forward := Hedr; - Status := OK_Not_Empty; - end if; - end if; - - SSL.Unlock_Task.all; - end Remqti; - -end System.Aux_DEC; |