|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - downloadIndex: ┃ B T ┃
Length: 21031 (0x5227)
Types: TextFile
Names: »B«
└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
└─ ⟦0c20f784e⟧ »DATA«
└─⟦1abbe589f⟧
└─⟦059497ac5⟧
└─⟦this⟧
with Unchecked_Deallocation;
with Xlbt_Arithmetic;
use Xlbt_Arithmetic;
with Xlbt_Exceptions;
use Xlbt_Exceptions;
with Xlbmt_Network_Types;
use Xlbmt_Network_Types;
package body Xlbt_Univ_Ptr is
------------------------------------------------------------------------------
-- X Library Machine Types
--
-- Xlbt_Univ_Ptr - Machine/Compiler dependent universal-pointer interface
------------------------------------------------------------------------------
-- Copyright 1989 - 1991 by Rational, Santa Clara, California.
--
-- All Rights Reserved.
--
-- Permission to use, copy, modify, and distribute this software and its
-- documentation for any purpose and without fee is hereby granted,
-- provided that the above copyright notice(s) appear in all copies and that
-- both that copyright notice(s) and this permission notice appear in
-- supporting documentation, and that the name of Rational not be used in
-- advertising or publicity pertaining to distribution of the software
-- without specific, written prior permission.
--
-- Rational disclaims all warranties with regard to this software, including
-- all implied warranties of merchantability and fitness, in no event shall
-- Rational be liable for any special, indirect or consequential damages or
-- any damages whatsoever resulting from loss of use, data or profits, whether
-- in an action of contract, negligence or other tortious action, arising out
-- of or in connection with the use or performance of this software.
------------------------------------------------------------------------------
type X_Universal_Pointer_Rec is
record
Signature : X_Pointer_Signature;
Access_Value : S_Natural;
end record;
procedure Free_X_Universal is
new Unchecked_Deallocation (X_Universal_Pointer_Rec,
X_Universal_Pointer);
Mutex : X_Mutex ----Used for multitask interlocking.
--/ if Multitask_Locking then
:= new X_Mutex_Rec
--/ end if;
;
Signatures : X_Pointer_Signature := None_X_Pointer_Signature;
----Used to allocate all signature values.
--\f
procedure Real_Free_X_Universal_Pointer_List is
new Unchecked_Deallocation (X_Universal_Pointer_Array,
X_Universal_Pointer_List);
procedure Free_X_Universal_Pointer_List
(List : in out X_Universal_Pointer_List) is
begin
Real_Free_X_Universal_Pointer_List (List);
end Free_X_Universal_Pointer_List;
--\f
procedure Next_Signature (Signature : out X_Pointer_Signature) is
------------------------------------------------------------------------------
-- Signature - Receives the next signature value
--
-- Called to obtain the next available unique signature value. 2**64 should
-- be a sufficient number of values. It is highly unlikely that an
-- instantiation of our generic package should be placed inside of a dynamic
-- context that would enter/leave a sufficient number of times to cause
-- a problem. (At least within the lifetime of the human race.)
------------------------------------------------------------------------------
begin
Lock_Mutex (Mutex);
begin
if Signatures.Second = S_Long'Last then
Signatures.Second := 0;
Signatures.First := Signatures.First + 1;
else
Signatures.Second := Signatures.Second + 1;
end if;
Signature := Signatures;
exception
when others =>
Unlock_Mutex (Mutex);
raise;
end;
Unlock_Mutex (Mutex);
end Next_Signature;
--\f
function X_Universal_Pointer_Signature (Ptr : X_Universal_Pointer)
return X_Pointer_Signature is
------------------------------------------------------------------------------
-- Ptr - Specifies the X_Universal_Pointer to use
--
-- Called to obtain the X_Pointer_Signature value for the specified universal
-- pointer value.
--
-- Raises X_Invalid_Universal_Pointer if
-- a) Ptr = None_X_Universal_Pointer, or,
-- b) Ptr is a freed universal pointer value (this may or may not be
-- detectable for all implementations and some other implementation
-- specific exception may be raised instead).
------------------------------------------------------------------------------
begin
if Ptr = None_X_Universal_Pointer or else
Ptr.Signature = None_X_Pointer_Signature then
raise X_Invalid_Universal_Pointer;
end if;
return Ptr.Signature;
end X_Universal_Pointer_Signature;
--\f
function X_Equal_Signature (Ptr1 : X_Universal_Pointer;
Ptr2 : X_Universal_Pointer) return Boolean is
--------------------------------------------------------------------------
-- Returns TRUE if a) either value is None or b) the signature value of the
-- first parameter is the same as the signature value for the second parameter.
------------------------------------------------------------------------------
begin
if Ptr1 = None_X_Universal_Pointer or else
Ptr2 = None_X_Universal_Pointer then
return True;
end if;
return Ptr1.Signature = Ptr2.Signature;
end X_Equal_Signature;
--\f
function X_Equal_Signature (Ptr : X_Universal_Pointer;
Sig : X_Pointer_Signature) return Boolean is
--------------------------------------------------------------------------
-- Returns TRUE if a) either value is None or b) the signature value of the
-- first parameter is the same as the signature value for the second parameter.
------------------------------------------------------------------------------
begin
if Ptr = None_X_Universal_Pointer then
return True;
end if;
return Sig = None_X_Pointer_Signature or else
Ptr.Signature = Sig;
end X_Equal_Signature;
--\f
function X_Equal_Signature (Sig1 : X_Pointer_Signature;
Sig2 : X_Pointer_Signature) return Boolean is
--------------------------------------------------------------------------
-- Returns TRUE if a) either value is None or b) the signature value of the
-- first parameter is the same as the signature value for the second parameter.
------------------------------------------------------------------------------
begin
return Sig1 = Sig2 or else
Sig1 = None_X_Pointer_Signature or else
Sig2 = None_X_Pointer_Signature;
end X_Equal_Signature;
--\f
package body X_Universal_Pointer_Conversion is
Our_Signature : X_Pointer_Signature;
----This is the signature value corresponding to this Access_Type.
type Access_Type_Array is
array (S_Natural range 0 .. 63) of Access_Type;
type Accesses_Rec;
type Accesses is access Accesses_Rec;
--/ if Enable_Deallocation then
pragma Enable_Deallocation (Accesses);
--/ end if;
type Accesses_Rec is
record
Next : Accesses := null; -- next block in chain of slots
Used : S_Natural := 0; -- number of used slots
Freei : S_Natural := 0; -- first free slot or Values'Last+1
Values : Access_Type_Array; -- slots
end record;
----All_Acc is the list of all Access_Type values.
-- Free_Acc is a pointer to the first block with a free slot.
-- Free_Blk is the index number of the first block with a free slot.
All_Acc : Accesses := null;
Free_Acc : Accesses := null;
Free_Blk : S_Natural := 0;
--\f
function To_X_Universal_Pointer
(Ptr : Access_Type) return X_Universal_Pointer is
------------------------------------------------------------------------------
-- Ptr - Specifies the Access_Type value to "convert"
--
-- Use this to exchange an Access_Type value for a universal pointer value.
-- The universal pointer may be used any number of times to retrieve the
-- same Access_Type value. Please note that if the Access_Type value is
-- freed then the universal pointer value becomes a "dangling pointer" and
-- it should be freed as well.
--
-- Returns None_X_Universal_Pointer if Ptr = null.
--
-- May raise implementation-specific exceptions in obscure cases, eg. type is
-- not fully elaborated yet (on systems that are capable of detecting it), or,
-- Storage_Error (on systems that implement this package by allocating storage).
--
-- Note: On some systems this allocates heap storage. Be sure to use the
-- Free_X_Universal_Pointer routine on all pointer values when they are no
-- longer required. This will prevent storage loss.
--
-- We keep an "array" of slots where we store pointer values. We implement
-- the array as a linked list of records, each record contains N pointers.
-- We keep two pointers. a) the list of all records and b) the first record
-- that had an empty slot the last time we looked. We find an empty slot
-- in the array and we store the access value there. We return the index of
-- the array slot.
------------------------------------------------------------------------------
Up : X_Universal_Pointer := new X_Universal_Pointer_Rec;
begin
----Check for null.
Up.Signature := Our_Signature;
if Ptr = null then
return None_X_Universal_Pointer;
end if;
Lock_Mutex (Mutex);
begin
----If there are not old access values then start the list with the first
-- record.
if All_Acc = null then
All_Acc := new Accesses_Rec;
Free_Acc := All_Acc;
Free_Acc.Used := 1;
Free_Acc.Freei := 1;
All_Acc.Values (0) := Ptr;
Up.Access_Value := 0;
Unlock_Mutex (Mutex);
return Up;
----Look for an empty slot.
else
loop
----See if the current Free_Acc has an empty slot. Use it if it does.
for I in Free_Acc.Freei .. Free_Acc.Values'Last loop
if Free_Acc.Values (I) = null then
Free_Acc.Used := Free_Acc.Used + 1;
if Free_Acc.Used >=
Access_Type_Array'Length then
Free_Acc.Freei :=
Access_Type_Array'Last + 1;
else
Free_Acc.Freei := I + 1;
end if;
Free_Acc.Values (I) := Ptr;
Up.Access_Value := Free_Blk + I;
Unlock_Mutex (Mutex);
return Up;
end if;
end loop;
----Go look at the next Free_Acc. Create it if necessary.
Free_Blk := Free_Blk + Access_Type_Array'Length;
if Free_Acc.Next = null then
Free_Acc.Next := new Accesses_Rec;
Free_Acc := Free_Acc.Next;
end if;
end loop;
end if;
----Catch unexpected exceptions.
exception
when others =>
Free_Acc := All_Acc;
Free_Blk := 0;
Free_X_Universal (Up);
Unlock_Mutex (Mutex);
raise;
end;
end To_X_Universal_Pointer;
--\f
function From_X_Universal_Pointer
(Ptr : X_Universal_Pointer) return Access_Type is
------------------------------------------------------------------------------
-- Ptr - Specifies the universal pointer to "convert"
--
-- Use this to exchange a universal pointer for the Access_Type value that was
-- used initially to create the universal pointer value.
--
-- Returns null if Ptr = None_X_Universal_Pointer.
--
-- Raises X_Invalid_Universal_Pointer if
-- a) Ptr = None_X_Universal_Pointer, or,
-- b) the universal pointer value does not correspond to a value of this
-- Access_Type (the signature is different), or,
-- c) Ptr is a freed universal pointer value (this may or may not be
-- detectable for all implementations and some other implementation
-- specific exception may be raised instead).
--
-- Note: On some systems universal pointers are implemented by allocating heap
-- storage. Be sure to use the Free_X_Universal_Pointer routine on all pointer
-- values when they are no longer required. This will prevent storage loss.
--
-- We keep an "array" of slots where we store pointer values. We implement
-- the array as a linked list of records, each record contains N pointers.
-- We keep two pointers. a) the list of all records and b) the first record
-- that had an empty slot the last time we looked. We look up the slot
-- in the array indicated by the universal pointer and we return the contents.
------------------------------------------------------------------------------
Block : S_Natural;
Index : S_Natural;
Acc : Accesses;
Ap : Access_Type;
begin
----Check for null and check for invalid signatures.
if Ptr = None_X_Universal_Pointer then
return null;
elsif Ptr.Signature /= Our_Signature then
raise X_Invalid_Universal_Pointer;
end if;
----Locate the record containing the pointer. Walk down the linked list
-- until we reach the record that has the correct index range.
Lock_Mutex (Mutex);
begin
Index := Ptr.Access_Value rem Access_Type_Array'Length;
Block := Ptr.Access_Value - Index;
if Block < Free_Blk then
Acc := All_Acc;
else
Acc := Free_Acc;
Block := Block - Free_Blk;
end if;
while Block > 0 loop
Acc := Acc.Next;
Block := Block - Access_Type_Array'Length;
end loop;
Ap := Acc.Values (Index);
exception
when others =>
Unlock_Mutex (Mutex);
raise;
end;
Unlock_Mutex (Mutex);
return Ap;
end From_X_Universal_Pointer;
--\f
function Free_X_Universal_Pointer
(Ptr : X_Universal_Pointer) return Access_Type is
-----------------------------------------------------------------------------
-- Ptr - Specifies the universal pointer value to be freed
--
-- Called to free a universal pointer value when it is no longer needed.
-- This deallocates the universal pointer value (especially important if it
-- was allocated upon the heap). It does *not* deallocate the Access_Type value
-- and it does *not* reference the Access_Type value in any way. An Access_Type
-- value and the associated universal pointer value can be freed in any order.
--
-- Raises X_Invalid_Universal_Pointer if
-- a) Ptr = None_X_Universal_Pointer, or,
-- b) the universal pointer value does not correspond to a value of this
-- Access_Type (the signature is different), or,
-- c) Ptr is a freed universal pointer value (this may or may not be
-- detectable for all implementations and some other implementation
-- specific exception may be raised instead).
------------------------------------------------------------------------------
Block : S_Natural;
Index : S_Natural;
Acc : Accesses;
Ap : Access_Type;
begin
----Check for null and check for invalid signatures.
if Ptr = None_X_Universal_Pointer then
return null;
elsif Ptr.Signature /= Our_Signature then
raise X_Invalid_Universal_Pointer;
end if;
----Locate the record containing the pointer.
Index := Ptr.Access_Value rem Access_Type_Array'Length;
Block := Ptr.Access_Value - Index;
Lock_Mutex (Mutex);
begin
if Block < Free_Blk then
Acc := All_Acc;
Free_Blk := Block;
while Block > 0 loop
Acc := Acc.Next;
Block := Block - Access_Type_Array'Length;
end loop;
Free_Acc := Acc;
else
Acc := Free_Acc;
Block := Block - Free_Blk;
while Block > 0 loop
Acc := Acc.Next;
Block := Block - Access_Type_Array'Length;
end loop;
end if;
----Zap the Value slot.
if Acc.Freei < Index then
Acc.Freei := Index;
end if;
Acc.Used := Acc.Used - 1;
Ap := Acc.Values (Index);
Acc.Values (Index) := null;
Ptr.Signature := None_X_Pointer_Signature;
Ptr.Access_Value := S_Long'Last;
declare
P : X_Universal_Pointer := Ptr;
begin
Free_X_Universal (P);
end;
exception
when others =>
Unlock_Mutex (Mutex);
raise;
end;
Unlock_Mutex (Mutex);
return Ap;
end Free_X_Universal_Pointer;
--\f
procedure Free_X_Universal_Pointer (Ptr : in out X_Universal_Pointer) is
-----------------------------------------------------------------------------
-- Ptr - Specifies the universal pointer value to be freed
--
-- Called to free a universal pointer value when it is no longer needed.
-- This deallocates the universal pointer value (especially important if it
-- was allocated upon the heap). It does *not* deallocate the Access_Type value
-- and it does *not* reference the Access_Type value in any way. An Access_Type
-- value and the associated universal pointer value can be freed in any order.
--
-- Raises X_Invalid_Universal_Pointer if
-- a) Ptr = None_X_Universal_Pointer, or,
-- b) the universal pointer value does not correspond to a value of this
-- Access_Type (the signature is different), or,
-- c) Ptr is a freed universal pointer value (this may or may not be
-- detectable for all implementations and some other implementation
-- specific exception may be raised instead).
------------------------------------------------------------------------------
Ap : Access_Type := Free_X_Universal_Pointer (Ptr);
begin
Ptr := None_X_Universal_Pointer;
end Free_X_Universal_Pointer;
--\f
procedure Free_Both_X_Universal_Pointer
(Ptr : in out X_Universal_Pointer) is
-----------------------------------------------------------------------------
-- Ptr - Specifies the universal pointer value to be freed
--
-- Called to free a universal pointer value when it is no longer needed.
-- This deallocates the universal pointer value (especially important if it
-- was allocated upon the heap). It does *not* deallocate the Access_Type value
-- and it does *not* reference the Access_Type value in any way. An Access_Type
-- value and the associated universal pointer value can be freed in any order.
--
-- Raises X_Invalid_Universal_Pointer if
-- a) Ptr = None_X_Universal_Pointer, or,
-- b) the universal pointer value does not correspond to a value of this
-- Access_Type (the signature is different), or,
-- c) Ptr is a freed universal pointer value (this may or may not be
-- detectable for all implementations and some other implementation
-- specific exception may be raised instead).
------------------------------------------------------------------------------
Ap : Access_Type := Free_X_Universal_Pointer (Ptr);
begin
Ptr := None_X_Universal_Pointer;
Free_Access_Type (Ap);
end Free_Both_X_Universal_Pointer;
--\f
begin
Next_Signature (Our_Signature);
end X_Universal_Pointer_Conversion;
--\f
end Xlbt_Univ_Ptr;