<> <> <> <> DIRECTORY AMBridge USING [GetWorld, nilRemotePointer, RemotePointer, SetTVFromLC, TVToLC, WordSequence, WordSequenceRecord], AMTypes USING [Class, Coerce, Error, IndexToTV, NComponents, New, nullType, Tag, TV, TVEqual, TVSize, TVType, Type, UnderClass, VariableType], PrincOpsUtils USING [LongCopy], RCMap USING [nullIndex], RTTypesBasicPrivate USING [AssignComposite, AssignCompositeNew, MapRefs, MapTiRcmx], RTTypesPrivate USING [GetValueAddress, TypedVariableRec, ValueAddress], RTTypesRemotePrivate USING [GetRemoteWords, RemoteStoreWords], SafeStorage USING [EquivalentTypes, nullType, Type], SafeStoragePrivate USING [ValidateRef]; AMVariablesImpl: PROGRAM IMPORTS AMBridge, AMTypes, PrincOpsUtils, SafeStoragePrivate, SafeStorage, RTTypesBasicPrivate, RTTypesPrivate, RTTypesRemotePrivate EXPORTS AMTypes = BEGIN OPEN AMTypes; <> TypedVariableRec: TYPE = RTTypesPrivate.TypedVariableRec; <> emptyTV: TV _ NIL; GetEmptyTV: PUBLIC SAFE PROC RETURNS [TV] = TRUSTED { IF emptyTV = NIL THEN { <> ws: AMBridge.WordSequence _ NEW[AMBridge.WordSequenceRecord[0]]; emptyTV _ NEW[TypedVariableRec _ [ referentType: [SafeStorage.nullType, NIL], head: [constant[]], status: const, field: constant[ws] ]]; }; RETURN[emptyTV]; }; Assign: PUBLIC SAFE PROC [lhs: TV, rhs: TV] = TRUSTED { DoAssign[lhs, rhs]; }; AssignNew: PUBLIC SAFE PROC [lhs: TV, rhs: TV] = TRUSTED{ DoAssign[lhs, rhs, TRUE]; }; DoAssign: PROC [lhs: TV, rhs: TV, new: BOOL _ FALSE] = { <> lhsType: Type = TVType[lhs]; rhsType: Type _ TVType[rhs]; rhsSize: INT _ TVSize[rhs]; lhsSize: INT _ TVSize[lhs]; lhsRemPtr: AMBridge.RemotePointer _ AMBridge.nilRemotePointer; rhsPtr: LONG POINTER _ NIL; unCountedAssignment: BOOL; isRC: BOOL _ IsRC[lhsType]; lhsa: RTTypesPrivate.ValueAddress _ RTTypesPrivate.GetValueAddress[tv: lhs, mutableOnly: TRUE]; ws: AMBridge.WordSequence _ NIL; SELECT UnderClass[lhsType] FROM any, globalFrame, localFrame => Error[reason: typeFault, type: lhsType]; ENDCASE; SELECT UnderClass[rhsType] FROM any, globalFrame, localFrame => Error[reason: typeFault, type: rhsType]; ENDCASE; { <> rhsa: RTTypesPrivate.ValueAddress _ RTTypesPrivate.GetValueAddress[rhs]; lhsa _ RTTypesPrivate.GetValueAddress[tv: lhs, mutableOnly: TRUE]; IF NOT AsGoodAs[rhsType: rhsType, lhsType: lhsType] THEN { <> ENABLE AMTypes.Error => IF reason = typeFault THEN GO TO incompatible; rhs _ AMTypes.Coerce[rhs, lhsType]; rhsType _ AMTypes.TVType[rhs]; rhsSize _ AMTypes.TVSize[rhs]; }; IF AMTypes.TVEqual[lhs, rhs] THEN RETURN; <> 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; SELECT TRUE FROM 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) ) => { <> IF rhsSize <= 2 AND AMBridge.TVToLC[rhs] = 0 THEN { <> rhsPtr _ @ws; -- the address of a NIL double-word GO TO copy; }; <> ERROR Error[reason: notImplemented, msg: "remote reference-counted assignment"]; }; rhsType = nullType => { rhsPtr _ @ws; -- the address of a NIL double-word SELECT UnderClass[lhsType] FROM list, ref, atom, rope, countedZone => { <> IF unCountedAssignment OR new THEN GO TO copy; LOOPHOLE[ NARROW[lhsa, pointer RTTypesPrivate.ValueAddress].ptr, REF REF ANY]^ _ NIL; RETURN; }; pointer, longPointer, procedure, signal, error => GO TO copy; basePointer, relativePointer, uncountedZone => GO TO copy; ENDCASE => GO TO incompatible; }; ENDCASE; IF NOT new AND rhsSize > lhsSize THEN <> GO TO incompatible; IF rhsSize = 0 THEN RETURN; IF NOT isRC AND rhsSize <= 2 THEN GO TO smallAssign; WITH t: rhsa SELECT FROM constant => { rhsPtr _ @t.value[0]; IF unCountedAssignment THEN GO TO copy ELSE GO TO rcAssign; }; pointer => { WITH fd: t.fd SELECT FROM large => { rhsPtr _ t.ptr; WITH rhs SELECT FROM tr: REF TypedVariableRec => WITH tr.head SELECT FROM fh => { <> procLeaf: PROC [r: REF ANY] = {SafeStoragePrivate.ValidateRef[r]}; RTTypesBasicPrivate.MapRefs[ ptr: t.ptr, rcmx: RTTypesBasicPrivate.MapTiRcmx[rhsType], procLeaf: procLeaf]; }; ENDCASE; ENDCASE; SELECT TRUE FROM unCountedAssignment => <> WITH fd: t.fd SELECT FROM large => {rhsPtr _ t.ptr; GO TO copy}; small => GO TO smallAssign; ENDCASE => ERROR; ENDCASE => GO TO rcAssign }; small => GO TO smallAssign; ENDCASE => ERROR}; remotePointer => { <> WITH fd: t.fd SELECT FROM large => { ws _ RTTypesRemotePrivate.GetRemoteWords[t.ptr, rhsSize]; rhsPtr _ @ws[0]; GO TO copy; }; small => GO TO smallAssign; ENDCASE => ERROR}; copiedRemoteObject => { <> WITH fd: t.fd SELECT FROM large => {rhsPtr _ t.ptr; GO TO copy}; small => GO TO smallAssign; ENDCASE => ERROR; }; ENDCASE => ERROR; EXITS copy => { <> lhsPtr: LONG POINTER _ NIL; WITH lh: lhsa SELECT FROM remotePointer => RTTypesRemotePrivate.RemoteStoreWords[from: rhsPtr, to: lh.ptr, nWords: rhsSize]; pointer => PrincOpsUtils.LongCopy[from: rhsPtr, to: lh.ptr, nwords: rhsSize]; copiedRemoteObject => PrincOpsUtils.LongCopy[from: rhsPtr, to: lh.ptr, nwords: rhsSize]; ENDCASE => ERROR; }; rcAssign => { <> lhsPtr: LONG POINTER _ NARROW[lhsa, pointer RTTypesPrivate.ValueAddress].ptr; IF new THEN RTTypesBasicPrivate.AssignCompositeNew[rhs: rhsPtr, lhs: lhsPtr, type: rhsType, nwords: rhsSize] ELSE RTTypesBasicPrivate.AssignComposite[rhs: rhsPtr, lhs: lhsPtr, type: rhsType, nwords: rhsSize]; }; smallAssign => <> AMBridge.SetTVFromLC[lhs, AMBridge.TVToLC[rhs]]; incompatible => <> ERROR Error[reason: incompatibleTypes, type: lhsType, otherType: rhsType]; }; }; TVTag: PROC [tv: TV] RETURNS [TV] = { <> RETURN[NARROW[tv, REF TypedVariableRec].referentType.tag]; }; Copy: PUBLIC SAFE PROC [tv: TV] RETURNS [newTV: TV _ NIL] = TRUSTED { IF tv # NIL THEN { tag: TV _ TVTag[tv]; type: 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: AMBridge.GetWorld[tv], type: type, tag: tag]; DoAssign[lhs: newTV, rhs: tv, new: TRUE]; }; }; IsRC: PROC [type: Type] RETURNS [ans: BOOL] = { <> RETURN[RTTypesBasicPrivate.MapTiRcmx[type] # RCMap.nullIndex]; }; AsGoodAs: PROC [rhsType,lhsType: Type] RETURNS [BOOL] = { <> <> RETURN[SafeStorage.EquivalentTypes[rhsType,lhsType]]; }; END.