From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/ada/s-auxdec.adb | 718 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 718 insertions(+) create mode 100644 gcc/ada/s-auxdec.adb (limited to 'gcc/ada/s-auxdec.adb') diff --git a/gcc/ada/s-auxdec.adb b/gcc/ada/s-auxdec.adb new file mode 100644 index 000000000..bfb489477 --- /dev/null +++ b/gcc/ada/s-auxdec.adb @@ -0,0 +1,718 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; -- cgit v1.2.3