<> <> <> <> DIRECTORY AMBridge USING[ GetWorld, nilRemotePointer, RemotePointer, SetTVFromLC, TVForReferent, TVToLC, WordSequence], AMTypes USING [ Class, Coerce, Error, IndexToTV, NComponents, New, Tag, TV, TVEqual, TVSize, TVType, TypeClass, TypedVariable, UnderType, 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, fhType, gfhType, 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; Type: TYPE = SafeStorage.Type; nullType: Type = SafeStorage.nullType; <> 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] = { <> 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; IF lhsType = SafeStorage.fhType OR lhsType = SafeStorage.gfhType THEN ERROR Error[reason: typeFault, type: lhsType]; IF rhsType = SafeStorage.fhType OR rhsType = SafeStorage.gfhType THEN ERROR Error[reason: typeFault, type: rhsType]; {--be real careful not to use the size field of lhsa if new 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 TypeClass[UnderType[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]; }; }; -- end DoAssign TVTag: PROC[tv: TypedVariable] RETURNS[TV] = { <> 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: 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.