RTTypesBridgeImpl.Mesa
Copyright © 1984, 1985 by Xerox Corporation. All rights reserved.
Russ Atkinson, April 8, 1985 8:44:02 pm PST
Richard Koo, July 2, 1984 5:01:47 pm PDT
Russ Atkinson (RRA) January 28, 1986 5:48:12 pm PST
DIRECTORY
AMBridge USING [TVHeadType, GetWorld, OctalRead, Loophole, WordSequence, RemotePointer, WordSequenceRecord],
AMTypes,
Atom USING [MakeAtom],
Basics USING [BITSHIFT, bitsPerWord, CARD, LongNumber, LowHalf],
PrincOpsUtils USING [LongCopy],
RCMap USING [nullIndex],
Rope USING [ROPE],
RTCommon USING [FetchField, FetchFieldLong, StoreFieldLong, Field],
RTSymbolDefs USING [SymbolTableBase, symbolIndexForTYPE],
RTSymbolOps USING [AcquireType],
RTSymbols USING [GetTypeSymbols, ReleaseSTB],
RTTypesBasicPrivate USING [MapTiRcmx],
RTTypesPrivate USING [TypedVariableRec, BitsForType, ValueAddress, FieldDescriptor, GetOrigin, GetValueAddress],
RTTypesRemotePrivate USING [GetRemoteGFHeader, GetRemoteWords, RemoteStoreWord, RemoteStoreDoubleWord, RemoteStoreFieldLong, GetRemoteWord, GetRemoteLC],
SafeStorage USING [GetReferentType, Type, nullType, anyType],
SafeStoragePrivate USING [ValidateRef],
WorldVM USING [CurrentIncarnation, Long, LocalWorld, World, CopyWrite];
RTTypesBridgeImpl:
PROGRAM
IMPORTS AMBridge, AMTypes, Atom, Basics, PrincOpsUtils, RTCommon, RTSymbolOps, RTSymbols, RTTypesBasicPrivate, RTTypesPrivate, RTTypesRemotePrivate, SafeStorage, SafeStoragePrivate, WorldVM
EXPORTS AMTypes, AMBridge, RTTypesPrivate
=
BEGIN
OPEN AMBridge, AMTypes, Basics, Rope, RTTypesPrivate, RTCommon, SafeStorage, RTTypesRemotePrivate, WorldVM;
T Y P E S
Pointer:
TYPE =
LONG
POINTER;
CardPointer: TYPE = LONG POINTER TO CARD;
SmallCardPointer: TYPE = LONG POINTER TO CARDINAL;
IntPointer: TYPE = LONG POINTER TO INT;
SmallIntPointer: TYPE = LONG POINTER TO INTEGER;
TypedVariableRec: TYPE = RTTypesPrivate.TypedVariableRec;
ValueAddress: TYPE = RTTypesPrivate.ValueAddress;
checkMutable: BOOL ← TRUE;
PROCs exported to AMTypes
IsAtom:
PUBLIC
SAFE
PROC [tv:
TV
--ref any--]
RETURNS [ans:
BOOL ←
TRUE] =
TRUSTED {
[] ← Coerce[tv, CODE[ATOM] ! Error => {ans ← FALSE; CONTINUE}];
};
IsRope:
PUBLIC
SAFE
PROC [tv:
TV
--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:
TV]
RETURNS [AMBridge.TVHeadType] = {
WITH tv
SELECT
FROM
tvr: REF TypedVariableRec => RETURN[tvr.head.tag];
ENDCASE => RETURN[notTVRecord];
};
TVType:
PUBLIC
SAFE
PROC [tv:
TV]
RETURNS [type: Type] =
TRUSTED {
WITH tv
SELECT
FROM
tr: REF TypedVariableRec => RETURN[tr.referentType.type];
ENDCASE => IF tv = NIL THEN RETURN[nullType] ELSE ERROR;
};
TVStatus:
PUBLIC
SAFE
PROC [tv:
TV]
RETURNS [status: Status] =
TRUSTED {
WITH tv
SELECT
FROM
tr:
REF TypedVariableRec => {
IF (status ← tr.status) = mutable
THEN {
Must also check for non-started global frames, which cannot be modified. We must NOT check the started bit in the frame, since it does not properly reflect whether or not a module has been started (sigh).
WITH h: tr.head
SELECT
FROM
gfh => IF h.gfh.code.out THEN status ← readOnly;
remoteGFH => IF GetRemoteGFHeader[h.remoteGlobalFrameHandle].code.out THEN status ← readOnly;
ENDCASE;
};
};
ENDCASE => IF tv = NIL THEN status ← readOnly ELSE ERROR;
};
TVForReferent:
PUBLIC
PROC [ref:
REF, status: Status ← mutable]
RETURNS [tv:
TV] = {
makes a REF ANY accessible as a TV.
type: Type;
bitsForType: CARD;
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 ← RTTypesPrivate.BitsForType[type].bft;
IF bitsForType
IN [1..bitsPerWord)
THEN
tv ←
NEW[TypedVariableRec ← [
referentType: [type],
head: [reference[ref: ref]],
status: status,
field: embedded
[fd: [
wordOffset: 0,
extent: small[
field: [bitFirst: bitsPerWord-bitsForType, bitCount: bitsForType]]]]]]
ELSE
tv ←
NEW[TypedVariableRec ← [
referentType: [type],
head: [reference[ref: ref]],
status: status,
field: entire[]]];
TVForReadOnlyReferent:
PUBLIC
PROC [ref:
REF
READONLY
ANY]
RETURNS [
TV] = {
makes a TV accessible as a REF ANY.
RETURN[TVForReferent[ref: LOOPHOLE[ref], status: readOnly]];
};
RefFromTV:
PUBLIC
PROC [tv:
TV]
RETURNS [
REF
ANY] = {
Raises internalTV if value is not a collectible object, notMutable if TVStatus[tv] # mutable. NOTE the result may carry a wider (narrower?) type!
WITH tv
SELECT
FROM
tr:
REF TypedVariableRec =>
SELECT
TRUE
FROM
tr.tag # entire => ERROR Error[reason: internalTV];
checkMutable AND tr.status # mutable => ERROR Error[reason: notMutable];
ENDCASE =>
WITH head: tr.head
SELECT
FROM
reference => RETURN[head.ref];
ENDCASE => ERROR Error[reason: internalTV];
ENDCASE => ERROR;
};
ReadOnlyRefFromTV:
PUBLIC
PROC [tv:
TV
--, status: readOnly--]
RETURNS [
REF
READONLY
ANY] = {
raises internalTV Like RefFromTV, but accepts only readOnly TVs, returns REF READONLY.
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;
};
SomeRefFromTV:
PUBLIC
PROC [tv:
TV]
RETURNS [
REF
ANY] = {
Like RefFromTV, but copies instead of raising an error.
WITH tv
SELECT
FROM
tr:
REF TypedVariableRec =>
IF tr.tag # entire
OR (checkMutable
AND tr.status # mutable)
OR tr.head.tag # reference
THEN
WITH Copy[tv]
SELECT
FROM
tr:
REF TypedVariableRec =>
WITH head: tr.head
SELECT
FROM
reference => RETURN[head.ref];
ENDCASE => ERROR Error[reason: internalTV, msg: "not a REF head"];
ENDCASE => ERROR
ELSE RETURN[RefFromTV[tv]];
ENDCASE => ERROR;
};
TVForATOM:
PUBLIC
PROC [atom:
ATOM]
RETURNS [
TV
--atom--] = {
RETURN[TVForReadOnlyReferent[NEW[ATOM ← atom]]];
};
TVToATOM:
PUBLIC
PROC [tv:
TV
--atom--]
RETURNS [
ATOM] = {
raises typeFault
type: Type = UnderType[TVType[tv]];
SELECT TypeClass[type]
FROM
ref => IF Range[type] = anyType THEN RETURN [TVToATOM[Coerce[tv, CODE[ATOM]]]];
atom => RETURN [Atom.MakeAtom[TVToName[tv]]];
ENDCASE;
ERROR Error[reason: typeFault, type: type];
};
TVForROPE:
PUBLIC
PROC [rope:
ROPE]
RETURNS [
TV
--rope--] = {
use TVToName to get the ROPE back
RETURN[TVForReadOnlyReferent[NEW[ROPE ← rope]]];
};
TVForPointerReferent:
PUBLIC
PROC [ptr: Pointer, type: Type, status: Status ← mutable]
RETURNS [tv:
TV] = {
These procedures map Pointers, proc descs and frames to TypedVariables and vice versa.
bitsForType: CARD ← bitsPerWord--not smaller than a word--;
IF ptr = NIL THEN RETURN[NIL];
bitsForType ← RTTypesPrivate.BitsForType[
type
! Error => IF reason = typeFault THEN CONTINUE; -- not smaller than a word
].bft;
IF bitsForType
IN [1..bitsPerWord)
THEN
tv ←
NEW[TypedVariableRec ← [
referentType: [type],
head: [pointer[ptr: ptr]],
status: status,
field: embedded[fd: [
wordOffset: 0,
extent: small[field: [bitFirst: bitsPerWord-bitsForType, bitCount: bitsForType]]]]]]
ELSE
tv ←
NEW[TypedVariableRec ← [
referentType: [type],
head: [pointer[ptr: ptr]],
status: status,
field: entire[]]];
PointerFromTV:
PUBLIC
PROC [tv:
TV]
RETURNS [p: Pointer ←
NIL] = {
raises typeFault
Raises internalTV if tv is embedded and not word aligned
Raises notMutable if TVStatus[tv] # mutable.
IF tv #
NIL
THEN
WITH tv
SELECT
FROM
tr:
REF TypedVariableRec => {
WITH head: tr.head
SELECT
FROM
pointer => p ← head.ptr;
reference => GO TO badType;
gfh => p ← head.gfh;
fh => p ← head.fh;
ENDCASE => GO TO badType;
IF checkMutable AND tr.status # mutable THEN ERROR Error[reason: notMutable];
WITH etr: tr
SELECT
FROM
embedded =>
WITH fd: etr.fd
SELECT
FROM
large => RETURN[p + fd.wordOffset];
small =>
IF fd.field.bitFirst = 0
THEN RETURN[p + fd.wordOffset]
ELSE ERROR Error[reason: internalTV];
ENDCASE => ERROR;
entire => RETURN[p]; --may have been narrowed--
ENDCASE => ERROR}
ENDCASE => GO TO badType;
EXITS badType => ERROR Error[reason: typeFault, type: nullType];
nilValueAddress: ValueAddress = MakeNilValueAddress[];
MakeNilValueAddress:
PROC
RETURNS [ValueAddress] = {
ws: WordSequence = NEW[WordSequenceRecord[SIZE[Pointer]]];
LOOPHOLE[@ws[0], LONG POINTER TO Pointer] ^ ← NIL;
RETURN[[constant[value: ws]]];
};
GetValueAddress:
PUBLIC
PROC [tv:
TV, mutableOnly:
BOOL ←
FALSE]
RETURNS [ValueAddress] = {
Raises notMutable.
tr: REF TypedVariableRec ← NIL;
words: CARDINAL = AMTypes.TVSize[tv];
IF mutableOnly AND TVStatus[tv] # mutable THEN GO TO cantChange;
WITH tv
SELECT
FROM
temp:
REF TypedVariableRec => {
tr ← temp;
WITH etr: tr
SELECT
FROM
constant => RETURN [[constant[etr.value]]];
ENDCASE;
};
ENDCASE => RETURN [nilValueAddress];
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: words]]]]];
ENDCASE => ERROR};
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: words]]]]];
ENDCASE => ERROR};
gfh => {
ptr: Pointer ← 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: words]]]]];
ENDCASE => ERROR};
fh => {
ptr: Pointer ← 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: words]]]]];
ENDCASE => ERROR};
remotePointer => {
ptr: RemotePointer ← head.remotePointer;
WITH etr: tr
SELECT
FROM
embedded => {
ptr.ptr ← ptr.ptr + etr.fd.wordOffset;
RETURN[[remotePointer[ptr: ptr, fd: etr.fd]]]};
entire =>
RETURN[[remotePointer[ptr: ptr, fd: [wordOffset: 0, extent: large[size: words]]]]];
ENDCASE => ERROR};
remoteReference => {
ptr: RemotePointer ← [
world: head.remoteRef.world,
worldIncarnation: CurrentIncarnation[head.remoteRef.world],
ptr: head.remoteRef.ref];
WITH etr: tr
SELECT
FROM
embedded => {
ptr.ptr ← ptr.ptr + etr.fd.wordOffset;
RETURN[[remotePointer[ptr: ptr, fd: etr.fd]]]};
entire =>
RETURN[[remotePointer[ptr: ptr, fd: [wordOffset: 0, extent: large[size: words]]]]];
ENDCASE => ERROR};
copiedRemoteObject => {
ptr: Pointer ← @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: words]]]]];
ENDCASE => ERROR};
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 ← ptr.ptr + etr.fd.wordOffset;
RETURN[[remotePointer[ptr: ptr, fd: etr.fd]]];
};
entire =>
RETURN[[remotePointer[ptr: ptr, fd: [wordOffset: 0, extent: large[size: words]]]]];
ENDCASE => ERROR};
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 ← ptr.ptr + etr.fd.wordOffset;
RETURN[[remotePointer[ptr: ptr, fd: etr.fd]]];
};
entire =>
RETURN[[remotePointer[ptr: ptr, fd: [wordOffset: 0, extent: large[size: words]]]]];
ENDCASE => ERROR};
ENDCASE => GO TO cantChange;
EXITS
cantChange => ERROR Error[reason: notMutable];
};
TVEq:
PUBLIC
SAFE
PROC [tv1, tv2:
TV]
RETURNS [
BOOL] =
TRUSTED {
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.
RETURN[EQValueAddress[GetValueAddress[tv1], GetValueAddress[tv2]]];
};
EQValueAddress:
PROC [a1, a2: ValueAddress]
RETURNS [
BOOL] = {
fd1, fd2: RTTypesPrivate.FieldDescriptor;
WITH t: a1
SELECT
FROM
constant => {
ws: WordSequence = NARROW[a2, constant ValueAddress].value;
IF a2.tag # constant OR t.value.size # ws.size THEN RETURN[FALSE];
FOR i:
NAT
IN [0..t.value.size)
DO
IF t.value[i] # ws[i] THEN RETURN[FALSE];
ENDLOOP;
RETURN[TRUE]};
pointer => {
IF a2.tag # pointer THEN RETURN[FALSE];
IF t.ptr #
NARROW[a2, pointer ValueAddress].ptr
THEN RETURN[FALSE];
fd1 ← t.fd;
fd2 ← NARROW[a2, pointer ValueAddress].fd;
};
remotePointer => {
IF a2.tag # remotePointer THEN RETURN[FALSE];
IF t.ptr #
NARROW[a2, remotePointer ValueAddress].ptr
THEN RETURN[FALSE];
fd1 ← t.fd;
fd2 ← NARROW[a2, remotePointer ValueAddress].fd;
};
copiedRemoteObject => {
IF a2.tag # copiedRemoteObject THEN RETURN[FALSE];
IF t.ptr #
NARROW[a2, copiedRemoteObject ValueAddress].ptr
THEN RETURN[FALSE];
fd1 ← t.fd;
fd2 ← NARROW[a2, copiedRemoteObject ValueAddress].fd;
};
ENDCASE;
WITH f1: fd1
SELECT
FROM
small =>
WITH f2: fd2
SELECT
FROM
small => IF f1.field = f2.field THEN RETURN[TRUE];
ENDCASE;
large =>
WITH f2: fd2
SELECT
FROM
large => IF f1.size = f2.size THEN RETURN[TRUE];
ENDCASE;
ENDCASE;
RETURN[FALSE];
};
TVEqual:
PUBLIC
SAFE
PROC [tv1, tv2:
TV]
RETURNS [
BOOL] =
TRUSTED {
class1: Class ← AMTypes.UnderClass[AMTypes.TVType[tv1]];
class2: Class ← AMTypes.UnderClass[AMTypes.TVType[tv2]];
size1,size2: INT;
IF TVEq[tv1, tv2] THEN RETURN [TRUE];
SELECT class1
FROM
localFrame, globalFrame => RETURN [FALSE];
ENDCASE;
SELECT class2
FROM
localFrame, globalFrame => RETURN [FALSE];
ENDCASE;
size1 ← AMTypes.TVSize[tv1];
size2 ← AMTypes.TVSize[tv2];
IF size1 # size2 THEN RETURN [FALSE];
IF size1 <= 2 THEN RETURN[TVToLC[tv1] = TVToLC[tv2]];
FOR i:
INT
IN [0..size1)
DO
IF AMBridge.OctalRead[tv1, i] # AMBridge.OctalRead[tv2, i] THEN RETURN[FALSE];
ENDLOOP;
RETURN[TRUE];
};
TVForType:
PUBLIC
PROC [type: Type]
RETURNS [ntv:
TV ←
NIL] = {
stb: RTSymbolDefs.SymbolTableBase = RTSymbols.GetTypeSymbols[type].stb;
{
ENABLE
UNWIND => RTSymbols.ReleaseSTB[stb];
ntv ← AMBridge.Loophole[
tv: TVForReferent[NEW[CARDINAL ← type]],
type: RTSymbolOps.AcquireType[stb, LOOPHOLE[RTSymbolDefs.symbolIndexForTYPE]]];
};
RTSymbols.ReleaseSTB[stb];
};
TVToLC:
PUBLIC
PROC [tv:
TV]
RETURNS [lc:
CARD] = {
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 CARD.
a: ValueAddress = GetValueAddress[tv];
ut: Type = AMTypes.UnderType[AMTypes.TVType[tv]];
size: CARDINAL = AMTypes.TVSize[tv];
org: INTEGER = RTTypesPrivate.GetOrigin[ut];
ptr: Pointer;
fd: RTTypesPrivate.FieldDescriptor;
WITH t: a
SELECT
FROM
constant =>
RETURN[
SELECT t.value.size
FROM
1 => LONG[LOOPHOLE[t.value[0], CARDINAL]] + org,
2 => LOOPHOLE[@t.value[0], CardPointer]^ + org,
ENDCASE => ERROR Error[reason: typeFault, type: ut]
];
pointer => {ptr ← t.ptr; fd ← t.fd};
remotePointer => {
WITH f: t.fd
SELECT
FROM
large => {
words: CARDINAL = MIN[f.size, size];
SELECT words
FROM
1 => lc ← LONG[LOOPHOLE[GetRemoteWord[remotePointer: t.ptr], CARDINAL]];
2 => lc ← GetRemoteLC[remotePointer: t.ptr];
ENDCASE => ERROR Error[reason: typeFault, type: ut];
lc ← LOOPHOLE[LOOPHOLE[lc, INT] + org, CARD];
RETURN};
small => {
word: WORD ← GetRemoteWord[remotePointer: t.ptr];
RETURN[FetchFieldLong[@word, f.field] + org]};
ENDCASE => ERROR};
copiedRemoteObject => {ptr ← t.ptr; fd ← t.fd};
ENDCASE => ERROR;
WITH f: fd
SELECT
FROM
large => {
words: CARDINAL = MIN[f.size, size];
SELECT words
FROM
1 => lc ← LONG[LOOPHOLE[ptr, SmallCardPointer]^];
2 => lc ← LOOPHOLE[ptr, CardPointer]^;
ENDCASE => ERROR Error[reason: typeFault, type: ut];
lc ← LOOPHOLE[LOOPHOLE[lc, INT] + org, CARD];
RETURN};
small => lc ← FetchFieldLong[ptr, f.field] + org;
ENDCASE => ERROR;
};
TVToInteger:
PUBLIC
PROC [tv:
TV]
RETURNS [
INTEGER] = {
RETURN[TVToLI[tv]]
};
TVToLI:
PUBLIC
PROC [tv:
TV]
RETURNS [
INT] = {
lc: CARD ← TVToLC[tv];
IF TVSize[tv] = 1
AND TypeClass[GroundStar[TVType[tv]]] = integer
THEN
RETURN[
LONG[
LOOPHOLE[Basics.LowHalf[lc],
INTEGER]]]
sign extend.
ELSE RETURN[LOOPHOLE[lc, INT]]};
TVToRef:
PUBLIC
PROC [tv:
TV]
RETURNS [ref:
REF] = {
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
nil => ref ← NIL;
atom, rope, list, ref => {
ref ← LOOPHOLE[TVToLC[tv], REF ANY];
IF TVHead[tv] = fh THEN SafeStoragePrivate.ValidateRef[ref];
};
ENDCASE => ERROR Error[reason: typeFault, type: TVType[tv]];
};
TVToReal:
PUBLIC
PROC [tv:
TV]
RETURNS [
REAL] = {
type: Type = AMTypes.TVType[tv];
ground: Type = AMTypes.GroundStar[type];
SELECT AMTypes.TypeClass[ground]
FROM
real => RETURN[LOOPHOLE[TVToLC[tv], REAL]];
integer => RETURN [TVToInteger[tv]];
longInteger => RETURN [TVToLI[tv]];
cardinal => RETURN [TVToCardinal[tv]];
longCardinal, unspecified => RETURN [TVToLC[tv]];
ENDCASE => ERROR AMTypes.Error[reason: typeFault, type: type];
};
TVToCardinal:
PUBLIC
PROC [tv:
TV]
RETURNS [
CARDINAL] = {
RETURN[TVToLC[tv]];
};
TVToCharacter:
PUBLIC
PROC [tv:
TV]
RETURNS [
CHAR] = {
raises rangeFault
ans: INTEGER = TVToInteger[tv];
IF ans
IN [(
FIRST[
CHAR] - 0C)..(
LAST[
CHAR] - 0C)]
THEN RETURN[LOOPHOLE[ans, CHAR]]
ELSE ERROR Error[reason: rangeFault];
TVToWordSequence:
PUBLIC
PROC [tv:
TV]
RETURNS [s: WordSequence] = {
ptr: Pointer;
words: CARDINAL = TVSize[tv];
SELECT words
FROM
0 => s ← NEW[WordSequenceRecord[0]];
1 => {
s ← NEW[WordSequenceRecord[1]];
s[0] ← TVToLC[tv];
RETURN;
};
2 => {
s ← NEW[WordSequenceRecord[2]];
LOOPHOLE[@s[0], CardPointer]^ ← TVToLC[tv];
RETURN;
};
ENDCASE => {
a: 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 ← NEW[WordSequenceRecord[words]];
PrincOpsUtils.LongCopy[from: ptr, nwords: words, to: @s[0]];
};
};
SetTVFromWordSequence:
PUBLIC
PROC [tv: AMTypes.
TV, ws: WordSequence] = {
type: Type = AMTypes.TVType[tv];
a: ValueAddress = RTTypesPrivate.GetValueAddress[tv: tv, mutableOnly: TRUE];
org: INTEGER = RTTypesPrivate.GetOrigin[type];
words: CARDINAL ← AMTypes.TVSize[tv];
IF ws.size < words THEN words ← ws.size;
IF words # 0
THEN {
lc:
CARD =
LOOPHOLE[(
LONG[
LOOPHOLE[ws[0],
INTEGER]] - org),
CARD];
RRA: We need to be careful about this arithmetic to avoid bounds faults when we don't want them. It is not clear that this is the right code, though.
src: Pointer ← @ws[0];
WITH t: a
SELECT
FROM
remotePointer => {
IF IsRC[type] THEN GO TO nonRC;
WITH fd: t.fd
SELECT
FROM
large => {
world: WorldVM.World = AMBridge.GetWorld[tv];
IF (words ←
MIN[words, fd.size]) # 0
THEN
WorldVM.CopyWrite[world: world, from: src, nwords: words, to: t.ptr.ptr];
};
small => {
IF Basics.BITSHIFT[1, fd.field.bitCount] <= lc THEN GO TO fault;
RTTypesRemotePrivate.RemoteStoreFieldLong[ptr: t.ptr, field: fd.field, value: lc]};
ENDCASE};
copiedRemoteObject =>
WITH fd: t.fd
SELECT
FROM
large =>
IF (words ←
MIN[words, fd.size]) # 0
THEN
PrincOpsUtils.LongCopy[from: src, nwords: words, to: t.ptr];
small => {
IF Basics.BITSHIFT[1, fd.field.bitCount] <= lc THEN GO TO fault;
RTCommon.StoreFieldLong[t.ptr, fd.field, lc]};
ENDCASE;
pointer => {
IF IsRC[type] THEN GO TO nonRC;
WITH fd: t.fd
SELECT
FROM
large =>
IF (words ←
MIN[words, fd.size]) # 0
THEN
PrincOpsUtils.LongCopy[from: src, nwords: words, to: t.ptr];
small => {
IF Basics.BITSHIFT[1, fd.field.bitCount] <= lc THEN GO TO fault;
RTCommon.StoreFieldLong[t.ptr, fd.field, lc]};
ENDCASE};
ENDCASE => ERROR;
EXITS
fault => ERROR AMTypes.Error[reason: rangeFault];
nonRC => ERROR AMTypes.Error[reason: typeFault, type: type];
};
};
SetTVFromLC:
PUBLIC
PROC [tv:
TV, lc:
CARD] = {
raises typeFault, rangeFault
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?
a: ValueAddress ← RTTypesPrivate.GetValueAddress[tv, TRUE];
type: Type = AMTypes.TVType[tv];
ut: Type = AMTypes.UnderType[type];
words: CARDINAL ← AMTypes.TVSize[tv];
lc ← LOOPHOLE[(LOOPHOLE[lc, INT] - RTTypesPrivate.GetOrigin[ut])];
IF words > 0
THEN {
WITH t: a
SELECT
FROM
pointer => {
IF IsRC[type] THEN GO TO badType;
WITH fd: t.fd
SELECT
FROM
large => {
SELECT (words ←
MIN[fd.size, words])
FROM
0 => {};
1 => LOOPHOLE[t.ptr, SmallCardPointer]^ ← lc;
2 => LOOPHOLE[t.ptr, CardPointer]^ ← lc;
ENDCASE => GO TO badType;
};
small => {
IF Basics.BITSHIFT[1, fd.field.bitCount] <= lc THEN GO TO badRange;
StoreFieldLong[t.ptr, fd.field, lc]};
ENDCASE => ERROR};
remotePointer => {
IF IsRC[type] THEN GO TO badType;
WITH fd: t.fd
SELECT
FROM
large => {
SELECT (words ←
MIN[fd.size, words])
FROM
0 => {};
1 => RemoteStoreWord[t.ptr, lc];
2 => RemoteStoreDoubleWord[t.ptr, lc];
ENDCASE => GO TO badType;
};
small => {
IF Basics.BITSHIFT[1, fd.field.bitCount] <= lc THEN GO TO badRange;
RemoteStoreFieldLong[ptr: t.ptr, field: fd.field, value: lc]};
ENDCASE => ERROR};
copiedRemoteObject => {
WITH fd: t.fd
SELECT
FROM
large => {
SELECT (words ←
MIN[fd.size, words])
FROM
0 => {};
1 => LOOPHOLE[t.ptr, SmallCardPointer]^ ← lc;
2 => LOOPHOLE[t.ptr, CardPointer]^ ← lc;
ENDCASE => GO TO badType;
};
small => {
IF Basics.BITSHIFT[1, fd.field.bitCount] <= lc THEN GO TO badRange;
StoreFieldLong[t.ptr, fd.field, lc]};
ENDCASE => ERROR;
};
ENDCASE => ERROR;
EXITS
badRange => ERROR AMTypes.Error[reason: rangeFault];
badType => ERROR AMTypes.Error[reason: typeFault, type: type];
};
};
SetTVFromLI:
PUBLIC
PROC [tv:
TV, li:
INT] = {
raises typeFault, rangeFault
a: ValueAddress ← GetValueAddress[tv, TRUE];
type: Type = TVType[tv];
ut: Type = AMTypes.UnderType[type];
class: Class ← AMTypes.TypeClass[ut];
words: CARDINAL ← AMTypes.TVSize[tv];
lc: CARD;
lp: Pointer;
li ← li - RTTypesPrivate.GetOrigin[type];
lc ← LOOPHOLE[li];
IF words > 0
THEN {
WITH t: a
SELECT
FROM
pointer => {
IF IsRC[type] THEN GO TO badType;
WITH fd: t.fd
SELECT
FROM
large => {
lp ← t.ptr;
SELECT (words ←
MIN[fd.size, words])
FROM
0 => {};
1 => GO TO short;
2 => GO TO long;
ENDCASE => GO TO badType};
small => {
IF Basics.BITSHIFT[1, fd.field.bitCount] <= lc THEN GO TO badRange;
StoreFieldLong[t.ptr, fd.field, lc]};
ENDCASE => ERROR};
remotePointer => {
IF IsRC[type] THEN GO TO badType;
WITH fd: t.fd
SELECT
FROM
large => {
SELECT (words ←
MIN[fd.size, words])
FROM
0 => {};
1 => {
avoid sign check for short integer
c: CARDINAL;
IF class = integer THEN {i: INTEGER ← li; c ← LOOPHOLE[i]} ELSE c ← li;
RemoteStoreWord[t.ptr, c];
};
2 => RemoteStoreDoubleWord[t.ptr, lc];
ENDCASE => GO TO badType};
small => {
IF Basics.BITSHIFT[1, fd.field.bitCount] <= lc THEN GO TO badRange;
RemoteStoreFieldLong[ptr: t.ptr, field: fd.field, value: lc]};
ENDCASE => ERROR};
copiedRemoteObject =>
WITH fd: t.fd
SELECT
FROM
large => {
lp ← t.ptr;
SELECT (words ←
MIN[fd.size, words])
FROM
0 => {};
1 => GO TO short;
2 => GO TO long;
ENDCASE => GO TO badType};
small => {
IF Basics.BITSHIFT[1, fd.field.bitCount] <= lc THEN GO TO badRange;
StoreFieldLong[t.ptr, fd.field, lc]};
ENDCASE => ERROR;
ENDCASE => ERROR;
EXITS
short => {
avoid sign check for short integer
IF class = integer
THEN LOOPHOLE[lp, LONG POINTER TO INTEGER]^ ← li
ELSE LOOPHOLE[lp, SmallCardPointer]^ ← lc;
};
long => LOOPHOLE[lp, LONG POINTER TO INT]^ ← li;
badRange => ERROR AMTypes.Error[reason: rangeFault];
badType => ERROR AMTypes.Error[reason: typeFault, type: type];
};
};
IsRC:
PROC [type: Type]
RETURNS [ans:
BOOL] = {
RETURN[RTTypesBasicPrivate.MapTiRcmx[type] # RCMap.nullIndex];
};
END.