AMVariablesImpl.Mesa
last modified on November 10, 1983 7:20 am by Paul Rovner
try to avoid acquisition of already acquired symbol tables
status stuff is wrong.
Russ Atkinson, April 27, 1983 10:42 pm
reformatted
try to get Coerce to occur earlier in DoAssign, since assignments of longInteger to subrange failed when they should not have
DIRECTORY
AMBridge USING[WordSequence, SetTVFromLC, TVToLC, GetWorld, TVForReferent],
AMTypes
USING [
TVType, TVSize, Error, TypeClass, UnderType, Coerce, Tag, IndexToTV, NComponents, New, VariableType, Class, TypedVariable, TV],
PrincOpsUtils USING[LongCOPY],
RCMap USING[nullIndex],
RTTypesBasicPrivate USING[MapTiRcmx, MapRefs, AssignCompositeNew, AssignComposite],
RTTypesPrivate USING[ValueAddress, GetValueAddress, TypedVariableRec],
RTTypesRemotePrivate USING[GetRemoteWords, RemoteStoreWords],
SafeStorage USING[Type, nullType, fhType, gfhType, EquivalentTypes],
SafeStoragePrivate USING[ValidateRef];
AMVariablesImpl:
PROGRAM
IMPORTS
AMBridge, AMTypes, PrincOpsUtils, SafeStoragePrivate, SafeStorage, RTTypesBasicPrivate, RTTypesPrivate, RTTypesRemotePrivate
EXPORTS AMTypes
=
BEGIN
OPEN
AMBridge, AMTypes, SafeStorage, SafeStoragePrivate, tp: RTTypesPrivate, RTTypesRemotePrivate;
T Y P E S
TypedVariableRec: TYPE = tp.TypedVariableRec;
emptyTV: TypedVariable = AMBridge.TVForReferent[NEW[REF ANY ← $EmptyTVReferent]];
GetEmptyTV:
PUBLIC
SAFE
PROC
RETURNS[TypedVariable] =
TRUSTED {
RETURN[emptyTV];
};
Assign:
PUBLIC
SAFE
PROC[lhs: TypedVariable, rhs: TypedVariable] =
TRUSTED {
DoAssign[lhs, rhs]};
AssignNew:
PUBLIC
SAFE
PROC[lhs: TypedVariable, rhs: TypedVariable] =
TRUSTED{
DoAssign[lhs, rhs, TRUE]};
DoAssign:
PROC[lhs: TypedVariable, rhs: TypedVariable, new:
BOOL ←
FALSE] = {
raises typeFault, notImplemented, incompatibleTypes, notMutable
lhsType: Type = TVType[lhs];
rhsType: Type = TVType[rhs];
size: CARDINAL = TVSize[rhs];
unCountedAssignment: BOOL;
isRC: BOOL = IsRC[lhsType];
IF lhsType = fhType
OR lhsType = gfhType
THEN ERROR Error[reason: typeFault, type: lhsType];
IF rhsType = fhType
OR rhsType = gfhType
THEN ERROR Error[reason: typeFault, type: rhsType];
{
--be real careful not to use the size field of lhsa if new
lhsa: tp.ValueAddress ← tp.GetValueAddress[tv: lhs, mutableOnly: TRUE];
rhsa: tp.ValueAddress ← tp.GetValueAddress[rhs];
IF isRC
AND ((lhsa.tag = remotePointer)
OR (lhsa.tag = pointer AND rhsa.tag = remotePointer)
OR (lhsa.tag = pointer AND rhsa.tag = copiedRemoteObject)
OR (lhsa.tag = copiedRemoteObject AND rhsa.tag = pointer)
)
THEN ERROR Error[reason: notImplemented, msg: "remote reference-counted assignment"];
WITH lhs
SELECT
FROM
tr:
REF TypedVariableRec =>
WITH tr.head
SELECT
FROM
constant, remoteConstant => ERROR Error[reason: notMutable];
reference, gfh => unCountedAssignment ← FALSE;
pointer, fh, remoteReference, copiedRemoteObject,
remotePointer, remoteGFH, remoteFH => unCountedAssignment ← TRUE;
ENDCASE => ERROR;
ENDCASE => ERROR;
IF rhsType = nullType
THEN {
SELECT TypeClass[UnderType[lhsType]]
FROM
list, ref, atom, rope, countedZone => {
this bunch is RC, so we can't use the zeroAssign outlet
IF unCountedAssignment
OR new
THEN
LOOPHOLE[
NARROW[lhsa, pointer tp.ValueAddress].ptr,
LONG POINTER TO LONG CARDINAL]^ ← 0
ELSE
LOOPHOLE[
NARROW[lhsa, pointer tp.ValueAddress].ptr,
REF REF ANY]^ ← NIL;
RETURN;
};
pointer, longPointer, procedure, signal, error, basePointer, relativePointer, uncountedZone =>
GO TO zeroAssign;
ENDCASE =>
GO TO incompatible;
IF
NOT AsGoodAs[rhsType: rhsType, lhsType: lhsType]
THEN {
ENABLE AMTypes.Error => IF reason = typeFault THEN GO TO incompatible;
DoAssign[lhs: lhs, rhs: AMTypes.Coerce[rhs, lhsType], new: new];
RETURN;
};
IF
NOT new
AND size > TVSize[lhs]
THEN
may be an uninitialized union or seq
GO TO incompatible;
WITH t: rhsa
SELECT
FROM
constant => {
SELECT
TRUE
FROM
NOT isRC
AND t.value.size <= 2 =>
NOTE non-RC, <= 2 words
GO TO smallAssign;
unCountedAssignment =>
NOTE remote RC not allowed
IF lhsa.tag = remotePointer
THEN
RemoteStoreWords[
from: @t.value[0],
to: NARROW[lhsa, remotePointer tp.ValueAddress].ptr,
nWords: t.value.size]
ELSE
PrincOpsUtils.LongCOPY[
from: @t.value[0],
to:
IF lhsa.tag = pointer
THEN NARROW[lhsa, pointer tp.ValueAddress].ptr
ELSE NARROW[lhsa, copiedRemoteObject tp.ValueAddress].ptr,
nwords: t.value.size];
new =>
RTTypesBasicPrivate.AssignCompositeNew[
rhs: @t.value[0],
lhs: NARROW[lhsa, pointer tp.ValueAddress].ptr,
type: rhsType,
nwords: t.value.size];
ENDCASE =>
RTTypesBasicPrivate.AssignComposite[
rhs: @t.value[0],
lhs: NARROW[lhsa, pointer tp.ValueAddress].ptr,
type: rhsType,
nwords: t.value.size];
};
pointer => {
WITH fd: t.fd
SELECT
FROM
large => {
IF fd.size <= 2 AND NOT isRC THEN GO TO smallAssign;
WITH rhs
SELECT
FROM
tr:
REF TypedVariableRec =>
WITH tr.head
SELECT
FROM
fh => {
validate rhs
OPEN RTTypesBasicPrivate;
procLeaf: PROC[r: REF ANY] = {ValidateRef[r]};
start here
MapRefs[ptr: t.ptr, rcmx: MapTiRcmx[rhsType], procLeaf: procLeaf];
};
ENDCASE;
ENDCASE;
SELECT
TRUE
FROM
unCountedAssignment => {
NOTE remote RC not allowed
IF lhsa.tag = remotePointer
THEN RemoteStoreWords [
from: t.ptr,
to: NARROW[lhsa, remotePointer tp.ValueAddress].ptr,
nWords: size]
ELSE PrincOpsUtils.LongCOPY [
from: t.ptr,
to:
IF lhsa.tag = pointer
THEN NARROW[lhsa, pointer tp.ValueAddress].ptr
ELSE NARROW[lhsa, copiedRemoteObject tp.ValueAddress].ptr,
nwords: size]};
new =>
RTTypesBasicPrivate.AssignCompositeNew[rhs: t.ptr,
lhs: NARROW[lhsa, pointer tp.ValueAddress].ptr,
type: rhsType,
nwords: size]
ENDCASE =>
RTTypesBasicPrivate.AssignComposite[rhs: t.ptr,
lhs: NARROW[lhsa, pointer tp.ValueAddress].ptr,
type: rhsType,
nwords: size]};
small => GO TO smallAssign;
ENDCASE => ERROR};
remotePointer => {
rhsa.tag = remotePointer
WITH fd: t.fd
SELECT
FROM
large => {
SELECT fd.size
FROM
<= 2 => GO TO smallAssign;
ENDCASE => {
ws: WordSequence = GetRemoteWords[t.ptr, size];
IF lhsa.tag = remotePointer
THEN RemoteStoreWords[
from: @ws[0],
to: NARROW[lhsa, remotePointer tp.ValueAddress].ptr,
nWords: size]
ELSE PrincOpsUtils.LongCOPY[
from: @ws[0],
to:
IF lhsa.tag = pointer
THEN NARROW[lhsa, pointer tp.ValueAddress].ptr
ELSE NARROW[lhsa, copiedRemoteObject tp.ValueAddress].ptr,
nwords: size]}};
small => GO TO smallAssign;
ENDCASE => ERROR};
copiedRemoteObject => {
rhsa.tag = copiedRemoteObject
WITH fd: t.fd
SELECT
FROM
large => {
IF fd.size <= 2 THEN GO TO smallAssign;
IF lhsa.tag = remotePointer
THEN RemoteStoreWords [
from: t.ptr,
to: NARROW[lhsa, remotePointer tp.ValueAddress].ptr,
nWords: size]
ELSE PrincOpsUtils.LongCOPY [
from: t.ptr,
to:
IF lhsa.tag = pointer
THEN NARROW[lhsa, pointer tp.ValueAddress].ptr
ELSE NARROW[lhsa, copiedRemoteObject tp.ValueAddress].ptr,
nwords: size];
};
small => GO TO smallAssign;
ENDCASE => ERROR;
};
ENDCASE => ERROR;
EXITS
smallAssign =>
must not be RC
SetTVFromLC[lhs, TVToLC[rhs]];
zeroAssign =>
must not be RC
SetTVFromLC[lhs, 0];
incompatible =>
we just can't assign these guys
ERROR Error[reason: incompatibleTypes, type: lhsType, otherType: rhsType];
};
TVTag:
PROC[tv: TypedVariable]
RETURNS[
TV] = {
COPIED in RTTypedVariablesImpl
RETURN[NARROW[tv, REF TypedVariableRec].referentType.tag];
};
Copy:
PUBLIC
SAFE
PROC[tv: TypedVariable]
RETURNS[newTV: TypedVariable] =
TRUSTED {
type: Type;
tag: TV ← NIL;
IF tv = NIL THEN RETURN[NIL];
tag ← TVTag[tv];
type ← TVType[tv];
IF tag =
NIL
THEN {
variantClass: Class = VariableType[type].c;
SELECT variantClass
FROM
union, sequence =>
tag ← Tag[IndexToTV[tv, NComponents[type]]];
ENDCASE;
};
newTV ← New[world: GetWorld[tv], type: type, tag: tag];
DoAssign[lhs: newTV, rhs: tv, new: TRUE];
};
IsRC:
PROC[type: Type]
RETURNS[ans:
BOOL] = {
copied in RTTypesBridgeImpl
RETURN[RTTypesBasicPrivate.MapTiRcmx[type] # RCMap.nullIndex]};
AsGoodAs:
PROC[rhsType,lhsType: Type]
RETURNS[
BOOL] =
{
copied in RTTypedVariablesImpl
RETURN[EquivalentTypes[rhsType,lhsType]]};-- NOTE freely conforms = Equivalent for now
END.