|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 34816 (0x8800)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body X_Universal_Pointer_Conversion, package body Xlbt_Univ_Ptr, seg_004f49
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦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.
--\x0c
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;
--\x0c
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;
--\x0c
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;
--\x0c
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;
--\x0c
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;
--\x0c
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;
--\x0c
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;
--\x0c
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;
--\x0c
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;
--\x0c
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;
--\x0c
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;
--\x0c
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;
--\x0c
begin
Next_Signature (Our_Signature);
end X_Universal_Pointer_Conversion;
--\x0c
end Xlbt_Univ_Ptr;
nblk1=21
nid=0
hdr6=42
[0x00] rec0=1b rec1=00 rec2=01 rec3=02e
[0x01] rec0=15 rec1=00 rec2=02 rec3=028
[0x02] rec0=00 rec1=00 rec2=21 rec3=006
[0x03] rec0=1a rec1=00 rec2=03 rec3=06c
[0x04] rec0=1c rec1=00 rec2=04 rec3=04a
[0x05] rec0=00 rec1=00 rec2=20 rec3=002
[0x06] rec0=19 rec1=00 rec2=05 rec3=026
[0x07] rec0=12 rec1=00 rec2=06 rec3=09e
[0x08] rec0=18 rec1=00 rec2=07 rec3=01a
[0x09] rec0=19 rec1=00 rec2=08 rec3=000
[0x0a] rec0=01 rec1=00 rec2=1f rec3=01e
[0x0b] rec0=14 rec1=00 rec2=09 rec3=0a0
[0x0c] rec0=01 rec1=00 rec2=1e rec3=002
[0x0d] rec0=15 rec1=00 rec2=0a rec3=042
[0x0e] rec0=1b rec1=00 rec2=0b rec3=026
[0x0f] rec0=00 rec1=00 rec2=1d rec3=042
[0x10] rec0=15 rec1=00 rec2=0c rec3=002
[0x11] rec0=00 rec1=00 rec2=1c rec3=012
[0x12] rec0=1c rec1=00 rec2=0d rec3=08c
[0x13] rec0=11 rec1=00 rec2=0e rec3=002
[0x14] rec0=1b rec1=00 rec2=0f rec3=006
[0x15] rec0=00 rec1=00 rec2=1b rec3=00e
[0x16] rec0=17 rec1=00 rec2=10 rec3=084
[0x17] rec0=00 rec1=00 rec2=1a rec3=004
[0x18] rec0=16 rec1=00 rec2=11 rec3=068
[0x19] rec0=01 rec1=00 rec2=19 rec3=008
[0x1a] rec0=1b rec1=00 rec2=12 rec3=026
[0x1b] rec0=00 rec1=00 rec2=18 rec3=016
[0x1c] rec0=1a rec1=00 rec2=13 rec3=02c
[0x1d] rec0=00 rec1=00 rec2=17 rec3=042
[0x1e] rec0=13 rec1=00 rec2=14 rec3=01e
[0x1f] rec0=14 rec1=00 rec2=15 rec3=062
[0x20] rec0=15 rec1=00 rec2=16 rec3=000
tail 0x217006a18819781c4b3e4 0x42a00088462063203