-- RTTypesBridgeImpl.Mesa -- last modified on December 16, 1982 8:49 pm by Paul Rovner DIRECTORY AMBridge USING[GetWorld, TVHeadType, WordSequence, WordSequenceRecord, RemotePointer], AMTypes, AtomsPrivate USING[GetAtom], Environment USING[bitsPerWord], Inline USING[BITSHIFT, LongCOPY, LongNumber, LowHalf, HighHalf], RCMap USING[nullIndex], Rope USING[ROPE], RTCommon USING[FetchField, FetchFieldLong, StoreFieldLong, ShortenLongCardinal, ShortenLongInteger, Field], RTStorageOps USING[ValidateRef], RTTBridge USING[], RTTypes USING[], RTTypesExtras, RTTypesBasic USING[GetReferentType, Type, nullType, anyType], RTTypesBasicPrivate USING[MapTiRcmx], RTTypesPrivate, RTTypesRemotePrivate USING[GetRemoteGFHeader, GetRemoteWords, RemoteStoreWord, RemoteStoreDoubleWord, RemoteStoreFieldLong, GetRemoteWord, GetRemoteLC], WorldVM USING[CurrentIncarnation, Long, LocalWorld]; RTTypesBridgeImpl: PROGRAM IMPORTS AMBridge, AtomsPrivate, RTCommon, RTStorageOps, RTTypesBasic, AMTypes, RTTypesPrivate, RTTypesBasicPrivate, RTTypesRemotePrivate, WorldVM EXPORTS AMTypes, AMBridge, RTTBridge, RTTypes, RTTypesExtras, RTTypesPrivate = BEGIN OPEN AMBridge, AMTypes, Environment, Rope, tp: RTTypesPrivate, RTCommon, RTTypesBasic, RTStorageOps, RTTypesRemotePrivate, WorldVM; -- T Y P E S TypedVariableRec: TYPE = tp.TypedVariableRec; Pointer: TYPE = LONG POINTER --TO UNSPECIFIED--; -- VARIABLES tvZone: ZONE; tvPrefixedZone: ZONE; -- PROCs exported to AMTypes IsAtom: PUBLIC SAFE PROC[tv: TypedVariable--ref any--] RETURNS[ans: BOOL _ TRUE] = TRUSTED {[] _ Coerce[tv, CODE[ATOM] ! Error => {ans _ FALSE; CONTINUE}]}; IsRope: PUBLIC SAFE PROC[tv: TypedVariable--ref any--] RETURNS[ans: BOOL _ TRUE] = TRUSTED {[] _ Coerce[tv, CODE[ROPE] ! Error => {ans _ FALSE; CONTINUE}]}; IsRefAny: PUBLIC SAFE PROC[type: Type--ref--] RETURNS[ans: BOOL _ TRUE] = TRUSTED {type _ UnderType[type]; RETURN[TypeClass[type] = ref AND Range[type] = anyType]}; TVHead: PUBLIC PROC[tv: TypedVariable] RETURNS[AMBridge.TVHeadType] = { IF tv = NIL THEN RETURN[notTVRecord]; WITH tv SELECT FROM tvr: REF TypedVariableRec => RETURN[tvr.head.tag]; ENDCASE => RETURN[notTVRecord]}; -- raises badTV TVType: PUBLIC SAFE PROC[tv: TypedVariable] RETURNS[type: Type] = TRUSTED { IF tv = NIL THEN RETURN[nullType]; WITH tv SELECT FROM tr: REF TypedVariableRec => RETURN[tr.referentType.type]; ENDCASE => ERROR}; TVStatus: PUBLIC SAFE PROC[tv: TypedVariable] RETURNS[Status] = TRUSTED { IF tv = NIL THEN RETURN[readOnly]; WITH tv SELECT FROM tr: REF TypedVariableRec => RETURN[tr.status]; ENDCASE => ERROR}; -- These procedures make a TypedVariable accessible as a REF ANY and vice versa. TVForReferent: PUBLIC PROC[ref: REF ANY, status: Status _ mutable] RETURNS[TypedVariable] = { type: Type; bitsForType: LONG CARDINAL; ValidateRef[ref]; WITH ref SELECT FROM a: ATOM => ERROR Error[reason: typeFault, type: CODE[ATOM]]; r: ROPE => ERROR Error[reason: typeFault, type: CODE[ROPE]]; ENDCASE; type _ GetReferentType[ref]; IF type = nullType THEN RETURN[NIL]; bitsForType _ tp.BitsForType[type].bft; RETURN[ IF bitsForType < bitsPerWord THEN tvZone.NEW [TypedVariableRec _ [referentType: [type], head: [reference[ref: ref]], status: status, field: embedded [fd: [wordOffset: 0, extent: small[field: [bitFirst: bitsPerWord-bitsForType, bitCount: ShortenLongCardinal[bitsForType]]]]]]] ELSE tvZone.NEW[TypedVariableRec _ [referentType: [type], head: [reference[ref: ref]], status: status, field: entire[]]]]}; TVForReadOnlyReferent: PUBLIC PROC[ref: REF READONLY ANY] RETURNS[TypedVariable] = {ValidateRef[LOOPHOLE[ref]]; RETURN[TVForReferent[ref: LOOPHOLE[ref], status: readOnly]]}; -- Raises internalTV if value is not a collectible object, notMutable if -- TVStatus[tv] # mutable. NOTE the result may carry a wider (narrower?) type! RefFromTV: PUBLIC PROC[tv: TypedVariable] RETURNS[REF ANY] = {WITH tv SELECT FROM tr: REF TypedVariableRec => {IF tr.tag # entire THEN ERROR Error[reason: internalTV] ELSE IF tr.status # mutable THEN ERROR Error[reason: notMutable] ELSE WITH head: tr.head SELECT FROM reference => RETURN[head.ref]; ENDCASE => ERROR Error[reason: internalTV]}; ENDCASE => ERROR}; -- raises internalTV -- Like RefFromTV, but accepts only readOnly TVs, returns REF READONLY. ReadOnlyRefFromTV: PUBLIC PROC[tv: TypedVariable --, status: readOnly--] RETURNS[REF READONLY ANY] = {WITH tv SELECT FROM tr: REF TypedVariableRec => {IF tr.tag # entire THEN ERROR Error[reason: internalTV] ELSE WITH head: tr.head SELECT FROM reference => RETURN[LOOPHOLE[head.ref]]; ENDCASE => ERROR Error[reason: internalTV]}; ENDCASE => ERROR}; -- One has a mutable TypedVariable that is not embedded. -- One wants a tv for a REF to the cell described by the TypedVariable. -- This may raise NotMutable or InternalTV, or return NIL if the referer type is not available. -- to be parsed TVFor(RefToTV) --TVForRefToTV: PUBLIC PROC[tv: TypedVariable] RETURNS[rtv: TypedVariable] = -- {t: Type _ RefType[TVType[tv]]; -- IF t = nullType THEN RETURN[NIL]; -- rtv _ New[t]; -- LOOPHOLE[rtv, REF REF ANY]^ _ RefFromTV[tv]}; -- Like RefFromTV, but copies instead of raising an error. SomeRefFromTV: PUBLIC PROC[tv: TypedVariable] RETURNS[REF ANY] = {WITH tv SELECT FROM tr: REF TypedVariableRec => {IF tr.tag # entire OR tr.status # mutable OR tr.head.tag # reference THEN RETURN[RefFromTV[Copy[tv]]] ELSE RETURN[RefFromTV[tv]]}; ENDCASE => ERROR}; TVForATOM: PUBLIC PROC[atom: ATOM] RETURNS[TypedVariable--atom--] = {RETURN[TVForReadOnlyReferent[NEW[ATOM _ atom]]]}; -- raises typeFault TVToATOM: PUBLIC PROC[tv: TypedVariable--atom--] RETURNS[ATOM] = { type: Type = UnderType[TVType[tv]]; RETURN [SELECT TypeClass[type] FROM ref => IF Range[type] = anyType THEN TVToATOM[Coerce[tv, CODE[ATOM]]] ELSE ERROR Error[reason: typeFault, type: type], atom => AtomsPrivate.GetAtom[TVToName[tv]], ENDCASE => ERROR Error[reason: typeFault, type: type]]; }; -- use TVToName to get the ROPE back TVForROPE: PUBLIC PROC[rope: ROPE] RETURNS[TypedVariable--rope--] = {RETURN[TVForReadOnlyReferent[NEW[ROPE _ rope]]]}; -- These procedures map Pointers, proc descs and frames to TypedVariables and vice versa. TVForPointerReferent: PUBLIC PROC[ptr: Pointer, type: Type, status: Status _ mutable] RETURNS[TypedVariable] = { bitsForType: LONG CARDINAL _ bitsPerWord--not smaller than a word--; IF ptr = NIL THEN RETURN[NIL]; bitsForType _ tp.BitsForType[type ! Error => IF reason = typeFault THEN CONTINUE; -- not smaller than a word ].bft; RETURN[ IF bitsForType < bitsPerWord THEN tvZone.NEW[TypedVariableRec _ [referentType: [type], head: [pointer[ptr: ptr]], status: status, field: embedded[fd: [wordOffset: 0, extent: small[field: [bitFirst: bitsPerWord-bitsForType, bitCount: ShortenLongCardinal[bitsForType]]]]]]] ELSE tvZone.NEW[TypedVariableRec _ [referentType: [type], head: [pointer[ptr: ptr]], status: status, field: entire[]]]]}; -- raises typeFault -- Raises internalTV if tv is embedded and not word aligned -- Raises notMutable if TVStatus[tv] # mutable. PointerFromTV: PUBLIC PROC[tv: TypedVariable] RETURNS[Pointer] = { GetHeadPointer: PROC[tr: REF TypedVariableRec] RETURNS[Pointer] = INLINE {RETURN[(WITH head: tr.head SELECT FROM pointer => head.ptr, reference => ERROR Error[reason: typeFault, type: nullType], gfh => LOOPHOLE[LONG[head.gfh]], fh => LOOPHOLE[LONG[head.fh]] ENDCASE => ERROR Error[reason: typeFault, type: nullType])]}; IF tv = NIL THEN RETURN[NIL]; WITH tv SELECT FROM tr: REF TypedVariableRec => {IF tr.status # mutable THEN ERROR Error[reason: notMutable]; WITH etr: tr SELECT FROM embedded => WITH fd: etr.fd SELECT FROM large => RETURN[GetHeadPointer[tr] + fd.wordOffset]; small => IF fd.field.bitFirst = 0 THEN RETURN[GetHeadPointer[tr] + fd.wordOffset] ELSE ERROR Error[reason: internalTV]; ENDCASE => ERROR; entire => RETURN[GetHeadPointer[tr]]; --may have been narrowed-- ENDCASE => ERROR} ENDCASE => ERROR Error[reason: typeFault, type: nullType]}; -- Raises notMutable GetValueAddress: PUBLIC PROC[tv: TypedVariable, mutableOnly: BOOLEAN _ FALSE] RETURNS[tp.ValueAddress] = {IF tv = NIL THEN IF mutableOnly THEN ERROR Error[reason: notMutable] ELSE {ws: WordSequence = NEW[WordSequenceRecord[2]]; LOOPHOLE[@ws[0], LONG POINTER TO LONG CARDINAL] ^ _ 0; RETURN[[constant[value: ws]]]}; IF mutableOnly THEN WITH tv SELECT FROM tr: REF TypedVariableRec => WITH h: tr.head SELECT FROM gfh => IF NOT h.gfh.started THEN ERROR Error[reason: notMutable]; remoteGFH => IF NOT GetRemoteGFHeader[h.remoteGlobalFrameHandle].started THEN ERROR Error[reason: notMutable]; ENDCASE; ENDCASE => ERROR; WITH tv SELECT FROM tr: REF TypedVariableRec => {IF mutableOnly AND tr.status # mutable THEN ERROR Error[reason: notMutable]; WITH head: tr.head SELECT FROM pointer => {ptr: Pointer _ head.ptr; WITH etr: tr SELECT FROM embedded => RETURN[[pointer[ptr: ptr + etr.fd.wordOffset, fd: etr.fd]]]; entire => RETURN[[pointer[ptr: ptr, fd: [wordOffset: 0, extent: large[size: TVSize[tv]]]]]]; ENDCASE => ERROR Error[reason: notMutable]}; reference => {ptr: Pointer _ LOOPHOLE[head.ref]; WITH etr: tr SELECT FROM embedded => RETURN[[pointer[ptr: ptr + etr.fd.wordOffset, fd: etr.fd]]]; entire => RETURN[[pointer[ptr: ptr, fd: [wordOffset: 0, extent: large[size: TVSize[tv]]]]]]; ENDCASE => ERROR Error[reason: notMutable]}; gfh => {ptr: Pointer _ LOOPHOLE[LONG[head.gfh]]; WITH etr: tr SELECT FROM embedded => RETURN[[pointer[ptr: ptr + etr.fd.wordOffset, fd: etr.fd]]]; entire => RETURN[[pointer[ptr: ptr, fd: [wordOffset: 0, extent: large[size: TVSize[tv]]]]]]; ENDCASE => ERROR Error[reason: notMutable]}; fh => {ptr: Pointer _ LOOPHOLE[LONG[head.fh]]; WITH etr: tr SELECT FROM embedded => RETURN[[pointer[ptr: ptr + etr.fd.wordOffset, fd: etr.fd]]]; entire => RETURN[[pointer[ptr: ptr, fd: [wordOffset: 0, extent: large[size: TVSize[tv]]]]]]; ENDCASE => ERROR Error[reason: notMutable]}; constant => WITH etr: tr SELECT FROM constant => RETURN[[constant[value: etr.value]]]; ENDCASE => ERROR; remotePointer => {ptr: RemotePointer _ head.remotePointer; WITH etr: tr SELECT FROM embedded => {ptr.ptr _ LOOPHOLE[ptr.ptr, LONG CARDINAL] + etr.fd.wordOffset; RETURN[[remotePointer[ptr: ptr, fd: etr.fd]]]}; entire => RETURN[[remotePointer[ptr: ptr, fd: [wordOffset: 0, extent: large[size: TVSize[tv]]]]]]; ENDCASE => ERROR Error[reason: notMutable]}; remoteReference => {ptr: RemotePointer _ [world: head.remoteRef.world, worldIncarnation: CurrentIncarnation[head.remoteRef.world], ptr: head.remoteRef.ref]; WITH etr: tr SELECT FROM embedded => {ptr.ptr _ LOOPHOLE[ptr.ptr, LONG CARDINAL] + etr.fd.wordOffset; RETURN[[remotePointer[ptr: ptr, fd: etr.fd]]]}; entire => RETURN[[remotePointer[ptr: ptr, fd: [wordOffset: 0, extent: large[size: TVSize[tv]]]]]]; ENDCASE => ERROR Error[reason: notMutable]}; copiedRemoteObject => {ptr: Pointer _ LOOPHOLE[@head.copy[0]]; WITH etr: tr SELECT FROM embedded => RETURN[[copiedRemoteObject[ptr: ptr + etr.fd.wordOffset, fd: etr.fd]]]; entire => RETURN[[copiedRemoteObject [ptr: ptr, fd: [wordOffset: 0, extent: large[size: TVSize[tv]]]]]]; ENDCASE => ERROR Error[reason: notMutable]}; remoteGFH => {ptr: RemotePointer _ [world: head.remoteGlobalFrameHandle.world, worldIncarnation: CurrentIncarnation[head.remoteGlobalFrameHandle.world], ptr: Long[world: head.remoteGlobalFrameHandle.world, addr: head.remoteGlobalFrameHandle.gfh]]; WITH etr: tr SELECT FROM embedded => {ptr.ptr _ LOOPHOLE[ptr.ptr, LONG CARDINAL] + etr.fd.wordOffset; RETURN[[remotePointer[ptr: ptr, fd: etr.fd]]]}; entire => RETURN[[remotePointer[ptr: ptr, fd: [wordOffset: 0, extent: large[size: TVSize[tv]]]]]]; ENDCASE => ERROR Error[reason: notMutable]}; remoteFH => {ptr: RemotePointer _ [world: head.remoteFrameHandle.world, worldIncarnation: CurrentIncarnation[head.remoteFrameHandle.world], ptr: Long[world: head.remoteFrameHandle.world, addr: head.remoteFrameHandle.fh]]; WITH etr: tr SELECT FROM embedded => {ptr.ptr _ LOOPHOLE[ptr.ptr, LONG CARDINAL] + etr.fd.wordOffset; RETURN[[remotePointer[ptr: ptr, fd: etr.fd]]]}; entire => RETURN[[remotePointer[ptr: ptr, fd: [wordOffset: 0, extent: large[size: TVSize[tv]]]]]]; ENDCASE => ERROR Error[reason: notMutable]}; remoteConstant => WITH etr: tr SELECT FROM constant => RETURN[[constant[value: etr.value]]]; ENDCASE => ERROR; ENDCASE => ERROR Error[reason: notMutable]}; ENDCASE => ERROR; }; -- end GetValueAddress -- Two TypedVariables are Eq if they address the same bits. -- Two TypedVariables are Equal if their values have the same size and the same bits. -- NOTE there is no type checking in these comparisons. TVEq: PUBLIC SAFE PROC[tv1, tv2: TypedVariable] RETURNS [BOOLEAN] = TRUSTED {RETURN[EQValueAddress[GetValueAddress[tv1], GetValueAddress[tv2]]]}; EQValueAddress: PROC[a1, a2: tp.ValueAddress] RETURNS[BOOLEAN] = {fd1, fd2: tp.FieldDescriptor; WITH t: a1 SELECT FROM constant => {IF a2.tag # constant OR t.value.size # NARROW[a2, constant tp.ValueAddress].value.size THEN RETURN[FALSE]; FOR i: NAT IN [0..t.value.size) DO IF t.value[i] # NARROW[a2, constant tp.ValueAddress].value[i] THEN RETURN[FALSE]; ENDLOOP; RETURN[TRUE]}; pointer => {IF a2.tag # pointer THEN RETURN[FALSE]; IF t.ptr # NARROW[a2, pointer tp.ValueAddress].ptr THEN RETURN[FALSE]; fd1 _ t.fd; fd2 _ NARROW[a2, pointer tp.ValueAddress].fd; }; remotePointer => {IF a2.tag # remotePointer THEN RETURN[FALSE]; IF t.ptr # NARROW[a2, remotePointer tp.ValueAddress].ptr THEN RETURN[FALSE]; fd1 _ t.fd; fd2 _ NARROW[a2, remotePointer tp.ValueAddress].fd; }; copiedRemoteObject => {IF a2.tag # copiedRemoteObject THEN RETURN[FALSE]; IF t.ptr # NARROW[a2, copiedRemoteObject tp.ValueAddress].ptr THEN RETURN[FALSE]; fd1 _ t.fd; fd2 _ NARROW[a2, copiedRemoteObject tp.ValueAddress].fd; }; ENDCASE; WITH f1: fd1 SELECT FROM small => WITH f2: fd2 SELECT FROM small => IF f1.field # f2.field THEN RETURN[FALSE]; ENDCASE => RETURN[FALSE]; large => WITH f2: fd2 SELECT FROM large => IF f1.size # f2.size THEN RETURN[FALSE]; ENDCASE => RETURN[FALSE]; ENDCASE; RETURN[TRUE]}; TVEqual: PUBLIC SAFE PROC[tv1, tv2: TypedVariable] RETURNS [BOOLEAN] = TRUSTED {ws1: WordSequence; ws2: WordSequence; ws1 _ TVToWordSequence[tv1]; ws2 _ TVToWordSequence[tv2]; IF ws1.size <= 2 AND ws2.size <= 2 THEN RETURN[TVToLC[tv1] = TVToLC[tv2]]; IF ws1.size # ws2.size THEN RETURN[FALSE]; FOR i: NAT IN [0..ws1.size) DO IF ws1[i] # ws2[i] THEN RETURN[FALSE]; ENDLOOP; RETURN[TRUE]}; -- These procedures make 1 or 2 word values available as bit patterns, and vice versa. -- raises typeFault if the field is bigger than 2 words, else PUNs its value -- (right justified, zero filled) into a LONG CARDINAL. TVToLC: PUBLIC PROC[tv: TypedVariable] RETURNS[lc: LONG CARDINAL] = {a: tp.ValueAddress = GetValueAddress[tv]; ptr: Pointer; fd: tp.FieldDescriptor; WITH t: a SELECT FROM constant => RETURN[IF t.value.size > 2 THEN ERROR Error[reason: typeFault, type: TVType[tv]] ELSE LOOPHOLE[@t.value[0], LONG POINTER TO LONG CARDINAL]^ + tp.GetOrigin[TVType[tv]]]; pointer => {ptr _ t.ptr; fd _ t.fd}; remotePointer => {WITH f: t.fd SELECT FROM large => {SELECT f.size FROM 1 => lc _ GetRemoteWord[remotePointer: t.ptr]; 2 => lc _ GetRemoteLC[remotePointer: t.ptr]; ENDCASE => ERROR Error[reason: typeFault, type: TVType[tv]]; lc _ LOOPHOLE[LOOPHOLE[lc, LONG INTEGER] + tp.GetOrigin[TVType[tv]], LONG CARDINAL]; RETURN}; small => {word: UNSPECIFIED _ GetRemoteWord[remotePointer: t.ptr]; RETURN[FetchFieldLong[@word, f.field] + tp.GetOrigin[TVType[tv]]]}; ENDCASE => ERROR}; copiedRemoteObject => {ptr _ t.ptr; fd _ t.fd}; ENDCASE; WITH f: fd SELECT FROM large => {SELECT f.size FROM 1 => lc _ LOOPHOLE[ptr, LONG POINTER TO CARDINAL]^; 2 => lc _ LOOPHOLE[ptr, LONG POINTER TO LONG CARDINAL]^; ENDCASE => ERROR Error[reason: typeFault, type: TVType[tv]]; lc _ LOOPHOLE[LOOPHOLE[lc, LONG INTEGER] + tp.GetOrigin[TVType[tv]], LONG CARDINAL]; RETURN}; small => RETURN[FetchFieldLong[ptr, f.field] + tp.GetOrigin[TVType[tv]]]; ENDCASE => ERROR}; TVToInteger: PUBLIC PROC[tv: TypedVariable] RETURNS[INTEGER] = {RETURN[ShortenLongInteger[TVToLI[tv]]]}; TVToLI: PUBLIC PROC[tv: TypedVariable] RETURNS[LONG INTEGER] = {lc: LONG CARDINAL _ TVToLC[tv]; IF TVSize[tv] = 1 AND TypeClass[GroundStar[TVType[tv]]] = integer THEN RETURN[LONG[LOOPHOLE[LOOPHOLE[lc,Inline.LongNumber].lowbits, INTEGER]]] -- sign extend. ELSE RETURN[LOOPHOLE[lc, LONG INTEGER]]}; TVToRef: PUBLIC PROC[tv: TV] RETURNS[REF ANY] = { IF GetWorld[tv] # LocalWorld[] THEN ERROR Error[reason: typeFault, msg: "Can't get a local REF for a remote object"]; SELECT TypeClass[UnderType[TVType[tv]]] FROM atom, rope, list, ref => RETURN[LOOPHOLE[TVToLC[tv], REF ANY]]; ENDCASE => ERROR Error[reason: typeFault, type: TVType[tv]]; }; TVToReal: PUBLIC PROC[tv: TypedVariable] RETURNS[REAL] = {RETURN[LOOPHOLE[TVToLC[tv], REAL]]}; TVToCardinal: PUBLIC PROC[tv: TypedVariable] RETURNS[CARDINAL] = {RETURN[ShortenLongCardinal[TVToLC[tv]]]}; -- raises rangeFault TVToCharacter: PUBLIC PROC[tv: TypedVariable] RETURNS[CHARACTER] = { ans: INTEGER = TVToInteger[tv]; IF ans IN [(FIRST[CHARACTER] - 0C)..(LAST[CHARACTER] - 0C)] THEN RETURN[LOOPHOLE[ans, CHARACTER]] ELSE ERROR Error[reason: rangeFault]}; TVToWordSequence: PUBLIC PROC[tv: TypedVariable] RETURNS [s: WordSequence] = {ptr: Pointer; words: CARDINAL = TVSize[tv]; IF words = 2 THEN {s _ tvPrefixedZone.NEW[WordSequenceRecord[words]]; LOOPHOLE[@s[0], LONG POINTER TO LONG CARDINAL]^ _ TVToLC[tv]; RETURN}; IF words = 1 THEN {s _ tvPrefixedZone.NEW[WordSequenceRecord[words]]; LOOPHOLE[@s[0], LONG POINTER TO CARDINAL]^ _ ShortenLongCardinal[TVToLC[tv]]; RETURN}; {a: tp.ValueAddress _ GetValueAddress[tv]; WITH t: a SELECT FROM constant => RETURN[t.value]; pointer => ptr _ t.ptr; remotePointer => RETURN[GetRemoteWords[remotePointer: t.ptr, nWords: words]]; copiedRemoteObject => ptr _ t.ptr; ENDCASE => ERROR; s _ tvPrefixedZone.NEW[WordSequenceRecord[words]]; Inline.LongCOPY[from: ptr, nwords: words, to: @s[0]]}}; -- raises NotMutable if TVStatus[tv] # mutable -- raises TypeFault if the tv type is RC or its value is bigger than 2 words, -- else PUNs lc into TVType[tv] and assigns it to the field -- specified by tv. NOTE this is a LOOPHOLE which may cause -- bounds checking to miss a bounds violation -- NOTE what about immutable variant records? -- raises typeFault, rangeFault SetTVFromLC: PUBLIC PROC[tv: TypedVariable, lc: LONG CARDINAL] = { type: Type = TVType[tv]; {a: tp.ValueAddress _ GetValueAddress[tv, TRUE]; lc _ LOOPHOLE[(LOOPHOLE[lc, LONG INTEGER] - tp.GetOrigin[type]), LONG CARDINAL]; WITH t: a SELECT FROM pointer => {IF IsRC[type] THEN ERROR Error[reason: typeFault, type: type]; WITH fd: t.fd SELECT FROM large => SELECT fd.size FROM 1 => LOOPHOLE[t.ptr, LONG POINTER TO CARDINAL]^ _ ShortenLongCardinal[lc]; 2 => LOOPHOLE[t.ptr, LONG POINTER TO LONG CARDINAL]^ _ lc; ENDCASE => ERROR Error[reason: typeFault, type: type]; small => {IF Inline.BITSHIFT[1, fd.field.bitCount] <= lc THEN ERROR Error[reason: rangeFault]; StoreFieldLong[t.ptr, fd.field, lc]}; ENDCASE => ERROR}; remotePointer => {IF IsRC[type] THEN ERROR Error[reason: typeFault, type: type]; WITH fd: t.fd SELECT FROM large => SELECT fd.size FROM 1 => RemoteStoreWord[t.ptr, ShortenLongCardinal[lc]]; 2 => RemoteStoreDoubleWord[t.ptr, lc]; ENDCASE => ERROR Error[reason: typeFault, type: type]; small => {IF Inline.BITSHIFT[1, fd.field.bitCount] <= lc THEN ERROR Error[reason: rangeFault]; RemoteStoreFieldLong[ptr: t.ptr, field: fd.field, value: lc]}; ENDCASE => ERROR}; copiedRemoteObject => WITH fd: t.fd SELECT FROM large => SELECT fd.size FROM 1 => LOOPHOLE[t.ptr, LONG POINTER TO CARDINAL]^ _ ShortenLongCardinal[lc]; 2 => LOOPHOLE[t.ptr, LONG POINTER TO LONG CARDINAL]^ _ lc; ENDCASE => ERROR Error[reason: typeFault, type: type]; small => {IF Inline.BITSHIFT[1, fd.field.bitCount] <= lc THEN ERROR Error[reason: rangeFault]; StoreFieldLong[t.ptr, fd.field, lc]}; ENDCASE => ERROR; ENDCASE => ERROR; }}; -- raises typeFault, rangeFault SetTVFromLI: PUBLIC PROC[tv: TypedVariable, li: LONG INTEGER] = { type: Type = TVType[tv]; {a: tp.ValueAddress _ GetValueAddress[tv, TRUE]; li _ li - tp.GetOrigin[type]; WITH t: a SELECT FROM pointer => {IF IsRC[type] THEN ERROR Error[reason: typeFault, type: type]; WITH fd: t.fd SELECT FROM large => SELECT fd.size FROM 1 => LOOPHOLE[t.ptr, LONG POINTER TO INTEGER]^ _ ShortenLongInteger[li]; 2 => LOOPHOLE[t.ptr, LONG POINTER TO LONG INTEGER]^ _ li; ENDCASE => ERROR Error[reason: typeFault, type: type]; small => {lc: LONG CARDINAL = LOOPHOLE[li]; IF Inline.BITSHIFT[1, fd.field.bitCount] <= lc THEN ERROR Error[reason: rangeFault]; StoreFieldLong[t.ptr, fd.field, lc]}; ENDCASE => ERROR}; remotePointer => {IF IsRC[type] THEN ERROR Error[reason: typeFault, type: type]; WITH fd: t.fd SELECT FROM large => SELECT fd.size FROM 1 => RemoteStoreWord[t.ptr, ShortenLongInteger[li]]; 2 => RemoteStoreDoubleWord[t.ptr, li]; ENDCASE => ERROR Error[reason: typeFault, type: type]; small => {lc: LONG CARDINAL = LOOPHOLE[li]; IF Inline.BITSHIFT[1, fd.field.bitCount] <= lc THEN ERROR Error[reason: rangeFault]; RemoteStoreFieldLong[ptr: t.ptr, field: fd.field, value: lc]}; ENDCASE => ERROR}; copiedRemoteObject => WITH fd: t.fd SELECT FROM large => SELECT fd.size FROM 1 => LOOPHOLE[t.ptr, LONG POINTER TO INTEGER]^ _ ShortenLongInteger[li]; 2 => LOOPHOLE[t.ptr, LONG POINTER TO LONG INTEGER]^ _ li; ENDCASE => ERROR Error[reason: typeFault, type: type]; small => {lc: LONG CARDINAL = LOOPHOLE[li]; IF Inline.BITSHIFT[1, fd.field.bitCount] <= lc THEN ERROR Error[reason: rangeFault]; StoreFieldLong[t.ptr, fd.field, lc]}; ENDCASE => ERROR; ENDCASE => ERROR; }}; IsRC: PROC[type: Type] RETURNS[ans: BOOL] = {RETURN[RTTypesBasicPrivate.MapTiRcmx[type] # RCMap.nullIndex]}; -- START HERE [qz: tvZone, pz: tvPrefixedZone] _ tp.GetTVZones[]; END.