+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S Y S T E M . A U X _ D E C --
--- --
--- B o d y --
--- --
--- $Revision: 1.1.16.1 $
--- --
--- Copyright (C) 1992-2001 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 2, 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. See the GNU General Public License --
--- fOr mOre details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, Or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- 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 Unchecked_Conversion (LIU, Largest_Integer);
- function From_LI is new 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 Unchecked_Conversion (SA, Address);
- function From_A is new 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 - 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 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 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 Unchecked_Conversion (BU, Unsigned_Byte);
- function From_B is new 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 Unchecked_Conversion (WU, Unsigned_Word);
- function From_W is new 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 Unchecked_Conversion (LWU, Unsigned_Longword);
- function From_LW is new 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 Unchecked_Conversion (U32, Unsigned_32);
- function From_U32 is new 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 Unchecked_Conversion (QWU, Unsigned_Quadword);
- function From_QW is new 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 : in Natural;
- Success_Flag : out Boolean)
- is
- 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 : in Natural;
- Success_Flag : out Boolean)
- is
- 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 : in 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 : in 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 : in Integer;
- Retry_Count : in Natural;
- Old_Value : out Integer;
- Success_Flag : out Boolean)
- is
- 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 : in 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 : in Long_Integer;
- Retry_Count : in Natural;
- Old_Value : out Long_Integer;
- Success_Flag : out Boolean)
- is
- 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 Unchecked_Conversion (Integer, IU);
- function From_IU is new Unchecked_Conversion (IU, Integer);
-
- function To_LU is new Unchecked_Conversion (Long_Integer, LU);
- function From_LU is new Unchecked_Conversion (LU, Long_Integer);
-
- procedure And_Atomic
- (To : in out Aligned_Integer;
- From : in 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 : in Integer;
- Retry_Count : in Natural;
- Old_Value : out Integer;
- Success_Flag : out Boolean)
- is
- 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 : in 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 : in Long_Integer;
- Retry_Count : in Natural;
- Old_Value : out Long_Integer;
- Success_Flag : out Boolean)
- is
- 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 : in 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 : in Integer;
- Retry_Count : in Natural;
- Old_Value : out Integer;
- Success_Flag : out Boolean)
- is
- 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 : in 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 : in Long_Integer;
- Retry_Count : in Natural;
- Old_Value : out Long_Integer;
- Success_Flag : out Boolean)
- is
- 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 Unchecked_Conversion (Address, QR_Ptr);
- function From_QR_Ptr is new Unchecked_Conversion (QR_Ptr, Address);
-
- ------------
- -- Insqhi --
- ------------
-
- procedure Insqhi
- (Item : in Address;
- Header : in 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 : in 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 : in Address;
- Header : in 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 : in 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;
projects / msp430-gcc.git / blobdiff