RTTypedVariablesImpl.Mesa
Copyright © 1984 by Xerox Corporation. All rights reserved.
Russ Atkinson, July 13, 1984 5:29:18 pm PDT
DIRECTORY
AMBridge
USING
[GetWorld, GetWorldIncarnation, GFHFromTV, IsRemote, Loophole, RemoteGFHFromTV, RemotePointer, RemoteRef, SetTVFromLC, SetTVFromLI, TVForPointerReferent, TVForReadOnlyReferent, TVForReferent, TVForRemotePointerReferent, TVForRemoteReferent, TVToCardinal, TVToLC, TVToLI, TVToProc, TVToRemoteProc, TVToRemoteSignal, TVToRef, TVToSignal, TVToWordSequence, WordSequence, WordSequenceRecord],
AMTypes
USING
[Assign, Class, Domain, Error, First, Globals, IndexToName, IndexToType, IsAtom, IsComputed, IsOverlaid, IsRope, Last, Locals, NameToIndex, NComponents, Range, ReferentStatus, Size, Status, TVStatus, TVType, TypeClass, UnderType, VariableType, TV, TypedVariable, Index],
AtomPrivate USING[AtomRec],
Basics USING[bitsPerWord],
List USING[AList],
LoaderOps USING[GetFrame, IR, IRRecord, IsNullLink],
PrincOps USING[GlobalFrameHandle, ProcDesc, SignalDesc],
RemoteRope USING[RemoteFetch, RemoteLength, RopeFromTV],
Rope USING[Fetch, Length, ROPE, RopeRep],
RTCommon USING[FetchField, FetchFieldLong, ShortenLongCardinal, ShortenLongInteger],
RTSymbolDefs
USING
[SymbolConstructorIndex, SymbolIdIndex, SymbolIndex, SymbolRecordIndex, SymbolTableBase],
RTSymbolOps
USING
[AcquireSequenceType, AcquireType, IDCardinalInfo, IDCardinalValue, ISEConstant, ISEImmutable, ISEType, IsSequence, SEBitsForType, SEUnderType, IsTypeSEI],
RTSymbols USING[GetTypeSymbols, ReleaseSTB],
RTTCache USING[FillIntEntry, IntEntry, LookupInt],
RTTypesPrivate,
RTTypesRemotePrivate
USING
[GetRemoteReferentType, GetRemoteWord, RemoteGFHToName, RemotePDToName, RemoteSEDToName, RemoteTypeToLocal],
SafeStorage
USING
[anyType, EquivalentTypes, fhType, GetCanonicalType, GetReferentType, gfhType, nullType, Type, unspecType],
SafeStoragePrivate USING[NewObject],
WorldVM USING[Address, CurrentIncarnation, LocalWorld, Long, World];
RTTypedVariablesImpl:
PROGRAM
IMPORTS
AMBridge, AMTypes, LoaderOps, RemoteRope, Rope, RTCommon, RTSymbolOps, RTSymbols, RTTCache, RTTypesPrivate, RTTypesRemotePrivate, SafeStorage, SafeStoragePrivate, WorldVM
EXPORTS AMTypes, AMBridge, RTTypesPrivate
SHARES Rope
=
BEGIN
OPEN
AMBridge, AMTypes, Basics, PrincOps, Rope, tp: RTTypesPrivate, RTCommon, SafeStoragePrivate, RTSymbolDefs, RTSymbolOps, RTSymbols, RTTCache, SafeStorage, RTTypesRemotePrivate, WorldVM;
T Y P E S
TypedVariableRec: TYPE = tp.TypedVariableRec;
Pointer: TYPE = LONG POINTER --TO UNSPECIFIED--;
V A R I A B L E S
underTYPE: Type = UnderType[CODE[Type]];
PROCs exported to AMTypes
New:
PUBLIC
SAFE
PROC
[type: Type, status: Status ← mutable, world: WorldVM.World ← NIL, tag: TV ← NIL]
RETURNS [newTV: TypedVariable] = TRUSTED {
raises typeFault
variantClass: Class;
length: CARDINAL ← 0;
IF type = nullType THEN RETURN[NIL];
IF type = fhType OR type = gfhType THEN ERROR Error[reason: typeFault, type: type];
IF world = NIL THEN world ← WorldVM.LocalWorld[];
variantClass ← VariableType[type].c;
variantClass = nil if type not a record or structure, or if non-variant (i.e. does
not contain a union or sequence)
IF tag # NIL AND variantClass = sequence THEN length ← TVToCardinal[tag];
IF world # WorldVM.LocalWorld[]
THEN {
make a new remote TV
IF tag #
NIL
AND (variantClass = union
OR variantClass = sequence)
THEN {
ws: WordSequence ← NEW[WordSequenceRecord[Size[type, length]]];
newTV:
TV ←
NEW[TypedVariableRec ← [
referentType: [
type,
IF IsComputed[type]
OR (variantClass = union
AND IsOverlaid[type])
THEN tag
ELSE NIL],
head: [copiedRemoteObject [
world: world,
worldIncarnation: CurrentIncarnation[world],
copy: ws]],
status: status,
field: entire[]]];
newTag: TV;
IF IsComputed[type]
OR (variantClass = union
AND IsOverlaid[type])
THEN RETURN[newTV];
here to initialize the tag of the new variant or sequence record
newTag ← Tag[LastComponent[newTV, type]]; -- assume sharing
NARROW[newTag, REF TypedVariableRec].status ← mutable;
Assign[lhs: newTag, rhs: tag];
NARROW[newTag, REF TypedVariableRec].status ← readOnly;
RETURN[newTV];
}
ELSE
RETURN [
NEW[TypedVariableRec ← [
referentType: [type],
head: [copiedRemoteObject [
world: world,
worldIncarnation: CurrentIncarnation[world],
copy: NEW[WordSequenceRecord[Size[type]]]]],
status: status,
field: entire[]]]]} -- end make a new remote TV
ELSE {
Make a new local TV.
RRA: Note that the type of the TV should retain the proper definitions level, although the type of the new object must be the canonical type. We do cheat a little here, but I doubt that we will be caught at it.
canon: Type = SafeStorage.GetCanonicalType[type];
newRef: REF = NewObject[type: canon, size: Size[type, length]];
internalTV: REF TypedVariableRec = NARROW[TVForReferent[newRef]];
internalTV.referentType ← [type];
newTV ← internalTV;
if a new variant or sequence record, initialize the tag
IF tag #
NIL
AND (variantClass = union
OR variantClass = sequence)
THEN
IF IsComputed[type]
OR (variantClass = union
AND IsOverlaid[type])
THEN internalTV.referentType.tag ← tag
ELSE {
newTag: REF TypedVariableRec ← NARROW[Tag[LastComponent[newTV, type]]];
IF newTag #
NIL
THEN {
newTag.status ← mutable;
Assign[lhs: newTag, rhs: tag];
newTag.status ← readOnly;
};
};
RETURN[newTV];
};
}; -- end New
TVTag:
PROC[tv: TypedVariable]
RETURNS[
TV] = {
COPIED in AMVariablesImpl
RETURN[NARROW[tv, REF TypedVariableRec].referentType.tag];
};
TVSize:
PUBLIC
SAFE
PROC[tv: TypedVariable]
RETURNS[
INT
--words--] =
TRUSTED {
Could overflow
lots of changes by RRA for speed and generality
type: Type = UnderType[TVType[tv]];
vClass: Class ← nil;
class: Class ← TypeClass[type];
SELECT class
FROM
localFrame => RETURN [TVSize[AMTypes.Locals[tv]]];
globalFrame => RETURN [TVSize[AMTypes.Globals[tv]]];
record, structure, sequence, union => {
SELECT class
FROM
record, structure => vClass ← VariableType[type].c;
sequence, union => vClass ← class;
ENDCASE;
IF vClass # nil
THEN {
IF (IsOverlaid[type]
OR IsComputed[type])
AND TVTag[tv] =
NIL
THEN RETURN[Size[type: type]];
SELECT vClass
FROM
union =>
RETURN [TVSize[Variant[LastComponent[tv, type]]]];
sequence =>
RETURN [Size[type: type, length: Length[LastComponent[tv, type]]]]
ENDCASE;
};
};
nil, ref, list, atom, rope, longPointer, basePointer, longCardinal, longInteger, real, countedZone, uncountedZone => RETURN [2];
integer, cardinal, character, pointer, unspecified, process, type, relativePointer, procedure, signal, error, program, port => RETURN [1];
ENDCASE;
RETURN[Size[type: type]];
};
Tag:
PUBLIC
SAFE
PROC[tv: TypedVariable
--union, sequence--]
RETURNS[ans: TypedVariable] = TRUSTED {
type: Type = TVType[tv];
stb: SymbolTableBase;
sei: SymbolIndex;
kludgeBits: NAT ← 0;
IF TVTag[tv] # NIL THEN RETURN[TVTag[tv]];
IF IsComputed[type]
OR IsOverlaid[type]
THEN
RETURN[
NIL];
[stb, sei] ← GetTypeSymbols[type];
{
ENABLE
UNWIND => ReleaseSTB[stb];
tagSei: SymbolIdIndex;
WITH stb
SELECT
FROM
t: SymbolTableBase.x =>
WITH ser: t.e.seb[t.e.UnderType[
NARROW[sei, SymbolIndex.x].e]]
SELECT
FROM
union => tagSei ← [x[ser.tagSei]];
sequence => tagSei ← [x[ser.tagSei]];
ENDCASE => ERROR Error[reason: typeFault, type: type];
t: SymbolTableBase.y =>
WITH ser: t.e.seb[t.e.UnderType[
NARROW[sei, SymbolIndex.x].e]]
SELECT
FROM
union => tagSei ← [y[ser.tagSei]];
sequence => tagSei ← [y[ser.tagSei]];
ENDCASE => ERROR Error[reason: typeFault, type: type];
ENDCASE => ERROR;
IF ISEConstant[stb, tagSei] THEN ERROR;
The following hack is courtesy of RRA, who just can't resist. The reason we have this here is that making an embedded TV is no easy task when the TV is a constant (particularly from an interface). In this case, the value container is a word sequence in the 'field' component of the object, rather than in the 'head' component. Blindly using the head component in Tag and Variant has caused problems for people who put variant record values in interfaces. We take advantage of the readonly nature of constants to share the underlying word sequence, although we have to skip the first word in the word sequence to get to the contents (kludge).
WITH tv
SELECT
FROM
rtr:
REF tp.TypedVariableRec =>
WITH etr: rtr
SELECT
FROM
constant => {
ntv: TV ← AMBridge.TVForReadOnlyReferent[etr.value];
tv ← AMBridge.Loophole[ntv, type];
kludgeBits ← bitsPerWord;
};
ENDCASE;
ENDCASE;
ans ←
NEW[TypedVariableRec ← [
referentType: [Domain[type]],
head: (
WITH tv
SELECT
FROM
tr: REF TypedVariableRec => tr.head,
ENDCASE => ERROR),
status: readOnly,
field: embedded[fd: BuildRecordFieldDescriptor [
parentTV: tv,
fieldBitOffset: kludgeBits + IDCardinalValue[stb, tagSei],
fieldBits: IDCardinalInfo[stb, tagSei],
bitsForType: SEBitsForType[stb, ISEType[stb, tagSei]]
]]
]];
};
ReleaseSTB[stb];
Variant:
PUBLIC
SAFE
PROC[tv: TypedVariable
--union--]
RETURNS[ans: TypedVariable ← NIL--record--] = TRUSTED {
type: Type = TVType[tv];
p:
PROC[stb: SymbolTableBase, isei: SymbolIdIndex] = {
wordOffset: NAT ← 0;
cType: Type ← AcquireType[
stb,
LOOPHOLE[SEUnderType[stb, LOOPHOLE[isei, SymbolIndex]], SymbolIndex]];
it is OK to LOOPHOLE the result, since we have checked the tag
ans ← AMBridge.Loophole[tv, cType];
IF LocalUnderClass[type] # union THEN ERROR Error[reason: typeFault, type: type];
tp.ComponentISEI[type, NameToIndex[type, TVToName[Tag[tv]]], p];
};
IndexToTV:
PUBLIC
SAFE
PROC[tv: TypedVariable
--record, structure--, index: Index]
RETURNS[TypedVariable] = TRUSTED {
[1..NComponents[TVType[tv]]]
cType: Type;
type: Type ← UnderType[TVType[tv]];
et: REF TypedVariableRec;
argRec: BOOL;
interfaceRec: BOOL;
bitsForTV: LONG CARDINAL;
BuildEmbeddedTV:
PROC[stb: SymbolTableBase, isei: SymbolIdIndex] = {
sei: SymbolIndex = ISEType[stb, isei];
csei: SymbolConstructorIndex ← SEUnderType[stb, sei];
bitsForType:
CARDINAL ← SEBitsForType[stb, sei];
bits for the value in the field
fieldBits:
CARDINAL ← IDCardinalInfo[stb, isei];
bits for the field
fieldBitOffset:
CARDINAL ←
IF argRec
THEN (
WITH stb
SELECT
FROM
t: SymbolTableBase.x =>
t.e.FnField[NARROW[isei, SymbolIdIndex.x].e].offset.wd*bitsPerWord,
t: SymbolTableBase.y =>
t.e.FnField[NARROW[isei, SymbolIdIndex.y].e].offset.wd*bitsPerWord,
ENDCASE => ERROR)
ELSE
IF interfaceRec
THEN IDCardinalValue[stb, isei]*bitsPerWord
ELSE IDCardinalValue[stb, isei];
bit offset of the field within the record
isSequence: BOOL ← FALSE;
WITH stb
SELECT
FROM
-- NOTE SymbolPack bug workaround
t: SymbolTableBase.x =>
WITH cse: t.e.seb[
NARROW[csei, SymbolConstructorIndex.x].e]
SELECT
FROM
relative => bitsForType ← t.e.BitsForType[cse.offsetType];
NOTE SymbolPack bug workaround
ENDCASE;
t: SymbolTableBase.y =>
WITH cse: t.e.seb[
NARROW[csei, SymbolConstructorIndex.y].e]
SELECT
FROM
relative => bitsForType ← t.e.BitsForType[cse.offsetType];
ENDCASE
ENDCASE => ERROR;
IF (
NOT Embedded[tv])
AND bitsForTV < bitsPerWord
if the entire tv is smaller than a word and in an allocated object
THEN fieldBitOffset ← fieldBitOffset + bitsPerWord - ShortenLongCardinal[bitsForTV];
IF IsSequence[stb, sei]
THEN {
recstb: SymbolTableBase;
recsei: SymbolIndex;
[recstb, recsei] ← GetTypeSymbols[type];
cType ← AcquireSequenceType[
stb, sei, recstb, LOOPHOLE[recsei, SymbolRecordIndex]
! UNWIND => ReleaseSTB[recstb]];
isSequence ← TRUE;
ReleaseSTB[recstb]}
ELSE cType ← AcquireType[stb, sei];
SELECT TRUE FROM
ISEConstant[stb, isei]
=> {
ENABLE Error => IF reason = notImplemented THEN GOTO nimp;
IF IsRemote[tv]
AND
NOT IsTypeSEI[ISEType[stb, isei]]
THEN et ← NEW[TypedVariableRec ← [
referentType: [cType, TVTag[tv]],
head: [remoteConstant [
world: GetWorld[tv],
worldIncarnation: GetWorldIncarnation[tv]]],
status: const,
field: constant[value: tp.GetIdConstantValue[tv, stb, isei]]
]]
ELSE et ← NEW[TypedVariableRec ← [
referentType: [cType, TVTag[tv]],
head: [constant[]],
status: const,
field: constant[value: tp.GetIdConstantValue[tv, stb, isei]]
]];
EXITS nimp => et ← NIL};
interfaceRec
AND
NOT IsInterfaceElementType[cType] => {
an interface variable (OUT OF DATE) the 16-bit value in the indicated field of the IR instance is... a (loadstate config index (identifies a BCD), index in linksary of EXPRecord for this interface in that BCD)
fD: tp.FieldDescriptor;
headP: Pointer;
ptr: POINTER;
status: Status ← mutable;
ir: LoaderOps.IR;
IF IsRemote[tv]
THEN
ERROR Error[reason: notImplemented, msg: "remote interface variables"];
WITH tv
SELECT
FROM
tr:
REF TypedVariableRec =>
WITH head: tr.head
SELECT
FROM
reference => ir ← NARROW[head.ref, LoaderOps.IR];
ENDCASE => ERROR Error[reason: internalTV];
ENDCASE => ERROR;
fD ← BuildRecordFieldDescriptor[tv, fieldBitOffset, 16, 16];
get the pointer to the interface record
headP ← LOOPHOLE[ir, Pointer];
pick up the pointer to the global variable. Maybe not bound.
ptr ←
LOOPHOLE[headP + fD.wordOffset,
LONG
POINTER
TO
POINTER]^;
IF LoaderOps.IsNullLink[ptr] THEN {et ← NIL; RETURN}; -- not bound
WITH stb
SELECT
FROM
t: SymbolTableBase.x =>
WITH e: t.e.seb[
NARROW[csei, SymbolConstructorIndex.x].e]
SELECT
FROM
ref =>
IF e.var
THEN {cType ← AcquireType[stb, [x[e.refType]]];
IF e.readOnly THEN status ← readOnly}
ELSE {
IF ISEImmutable[stb, isei]
THEN status ← readOnly};
old symbol table
ENDCASE =>
IF ISEImmutable[stb, isei]
THEN status ← readOnly;
old symbol table
t: SymbolTableBase.y =>
WITH e: t.e.seb[
NARROW[csei, SymbolConstructorIndex.y].e]
SELECT
FROM
ref =>
IF e.var
THEN {cType ← AcquireType[stb, [y[e.refType]]];
IF e.readOnly THEN status ← readOnly}
ELSE {
IF ISEImmutable[stb, isei]
THEN status ← readOnly};
old symbol table
ENDCASE =>
IF ISEImmutable[stb, isei]
THEN status ← readOnly;
old symbol table
ENDCASE => ERROR;
{
gfh: GlobalFrameHandle = LoaderOps.GetFrame[
interface: ir,
index: fD.wordOffset - SIZE[LoaderOps.IRRecord]];
et ← NEW[TypedVariableRec ← [
referentType: [cType],
head: [gfh[gfh: gfh]],
status: status,
field: embedded
[fd: BuildLargeFieldDescriptor[wordOffset: ptr-gfh, nWords: Size[cType]]]
]];
};
};
Constant[tv]
=>
WITH tv
SELECT
FROM
tr:
REF constant TypedVariableRec => {
wordOffset: CARDINAL ← fieldBitOffset / bitsPerWord;
words: CARDINAL ← fieldBits / bitsPerWord;
ws: WordSequence ← NEW[WordSequenceRecord[MAX[1, words]]];
IF words > 0
THEN {
RRA: this code did not use the offset prior to this change. We are even careful to pad with 0s if the value is not long enough.
lim: NAT = tr.value.size;
FOR i:
NAT
IN [0..words)
DO
ws[i] ← IF (i+wordOffset) >= lim THEN 0 ELSE tr.value[i+wordOffset];
ENDLOOP;
}
ELSE {
ws[0] ← FetchField[
@tr.value[wordOffset],
[bitFirst: fieldBitOffset MOD bitsPerWord, bitCount: fieldBits]];
};
IF IsRemote[tv]
THEN et ← NEW[TypedVariableRec ← [
referentType: [cType, TVTag[tv]],
head: [remoteConstant [
world: GetWorld[tv],
worldIncarnation: GetWorldIncarnation[tv]]],
status: const,
field: constant[value: ws]
]]
ELSE et ← NEW [TypedVariableRec ← [
referentType: [cType, TVTag[tv]],
head: [constant[]],
status: const,
field: constant[value: ws]
]];
};
ENDCASE => ERROR
ENDCASE => {
under: Type = UnderType[cType];
forceWords: BOOL ← FALSE;
wordOffset: CARDINAL ← 0;
SELECT TypeClass[under]
FROM
union => {
oddly enough, unions don't take entire words all of the time
IF fieldBits < bitsPerWord
THEN bitsForType ← fieldBits
ELSE forceWords ← TRUE;
};
sequence => forceWords ← TRUE;
ENDCASE;
IF forceWords
THEN
WITH tv
SELECT
FROM
embed:
REF embedded TypedVariableRec =>
wordOffset ← embed.fd.wordOffset;
ENDCASE;
et ← NEW[TypedVariableRec ← [
referentType: [cType, TVTag[tv]],
head: (
WITH tv
SELECT
FROM
tr: REF TypedVariableRec => tr.head,
ENDCASE => ERROR), -- [reference[ref: tv]]),
status: (
IF
NOT interfaceRec
AND ISEImmutable[stb, isei]
THEN readOnly
ELSE TVStatus[tv]),
field: embedded[fd: (
IF forceWords
THEN [wordOffset: wordOffset, extent: large[size: Size[type, 0]]]
ELSE BuildRecordFieldDescriptor[tv, fieldBitOffset, fieldBits, bitsForType]
)]]];
IF isSequence
THEN {
entry: RTTCache.IntEntry = RTTCache.LookupInt[under, GetSequenceOffset];
words: INT = Size[type, GetSequenceLength[et]];
WITH x: et
SELECT
FROM
embedded => x.fd.extent ← large[size: words];
ENDCASE => ERROR;
IF
NOT entry.valid
THEN
we may need the offset for later use (filed under the sequence type)
[] ← RTTCache.FillIntEntry[entry, Size[type, 0]];
};
}};
-- END BuildEmbeddedTV
Begin IndexToTV Here
[bitsForTV, argRec, interfaceRec] ← tp.BitsForType[type];
tp.RecordComponentISEI[type, index, BuildEmbeddedTV];
RETURN[et];
}; -- end IndexToTV
GetSequenceOffset:
SAFE
PROC [type: Type]
RETURNS [offset:
INT] =
TRUSTED {
... returns the word offset of the first element of the sequence, -1 if there is no entry (should not happen unless you got the sequence TV without going through IndexToTV). Note that if RTTCache ever changes to allow flushing of entries that entries of this flavor must never be flushed!
entry: RTTCache.IntEntry ← RTTCache.LookupInt[type, GetSequenceOffset];
offset ← entry.int;
GetSequenceLength:
SAFE
PROC [tv:
TV]
RETURNS [length:
INT ← 0] =
TRUSTED {
uses the tag field, then adjusts for the bottom of the range
tag: TV = Tag[tv];
IF tag #
NIL
THEN {
tagType: Type = TVType[tag];
length ← TVToLI[tag];
SELECT LocalUnderClass[tagType]
FROM
integer, longInteger, cardinal, longCardinal => {};
ENDCASE => length ← length - TVToLI[First[tagType]];
};
IsInterfaceElementType:
PROC[type: Type]
RETURNS[
BOOL] = {
SELECT LocalUnderClass[type]
FROM
program, procedure, signal, error => RETURN[TRUE];
ENDCASE => RETURN[FALSE];
TVToType:
PUBLIC
SAFE
PROC[tv: TypedVariable
--type--]
RETURNS[rtn: Type] =
TRUSTED {
raises typeFault
type: Type = UnderType[TVType[tv]];
class: Class ← TypeClass[type];
IF type = underTYPE THEN class ← type;
SELECT class
FROM
type =>
IF IsRemote[tv]
THEN rtn ← RemoteTypeToLocal[world: GetWorld[tv], remoteType: TVToCardinal[tv]]
ELSE rtn ← LOOPHOLE[TVToCardinal[tv], Type];
ENDCASE => ERROR Error[reason: typeFault, type: type];
PropertyList:
PUBLIC
SAFE
PROC
[tv: TypedVariable--atom--] RETURNS[rtn: TV--list--] = TRUSTED {
raises typeFault
type: Type = UnderType[TVType[tv]];
SELECT TypeClass[type]
FROM
-- NOTE assumption of remote AtomRec identity
atom =>
rtn ← Loophole[
IndexToTV[
Loophole[tv, CODE[REF AtomPrivate.AtomRec]],
NameToIndex[CODE[AtomPrivate.AtomRec], "propList"]],
CODE[List.AList]];
ENDCASE => ERROR Error[reason: typeFault, type: type];
TVToName:
PUBLIC
SAFE
PROC [tv: TypedVariable]
RETURNS[ans:
ROPE ←
NIL] =
TRUSTED {
requires that tv be a transfer, program, globalFrame, enumerated, atom, rope
type: Type = UnderType[TVType[tv]];
world: World = GetWorld[tv];
SELECT TypeClass[type]
FROM
ref => {
target: Type;
SELECT
TRUE
FROM
IsAtom[tv] => target ← CODE[ATOM];
IsRope[tv] => target ← CODE[ROPE];
ENDCASE => ERROR Error[reason: typeFault, type: type];
ans ← TVToName[Coerce[tv, target]];
};
atom =>
SELECT
TRUE
FROM
IsRemote[tv] =>
this is rather dangerous
ans ← RemoteRope.RopeFromTV[
TVForRemotePointerReferent[
remotePointer: [
world: world, worldIncarnation: CurrentIncarnation[world], ptr: TVToLC[tv]],
type: CODE[ROPE]]];
TVToLC[tv] # 0 =>
ans ← NARROW[TVToRef[tv], REF AtomPrivate.AtomRec].pName;
ENDCASE;
rope =>
IF IsRemote[tv]
THEN ans ← RemoteRope.RopeFromTV[tv]
ELSE ans ← NARROW[TVToRef[tv], ROPE];
enumerated => {
index: INT = TVToLC[tv] + 1;
IF index >
LAST[
CARDINAL]
THEN
ERROR Error[reason: notImplemented, msg: "gigantic enumerations", type: type];
ans ← IndexToName[type, index];
};
program, procedure =>
IF IsRemote[tv]
THEN ans ← RemotePDToName[TVToRemoteProc[tv]]
ELSE ans ← tp.PDToName[LOOPHOLE[TVToProc[tv], ProcDesc]];
signal, error =>
IF IsRemote[tv]
THEN ans ← RemoteSEDToName[TVToRemoteSignal[tv]]
ELSE ans ← tp.SEDToName[LOOPHOLE[TVToSignal[tv], SignalDesc]];
globalFrame =>
IF IsRemote[tv]
THEN ans ← RemoteGFHToName[RemoteGFHFromTV[tv]]
ELSE ans ← tp.GFHToName[GFHFromTV[tv]];
ENDCASE;
Apply:
PUBLIC
SAFE
PROC[mapper:
TV
--array, sequence, descriptor, longDescriptor--, arg:
TV]
RETURNS[embeddedTV: TV] = TRUSTED {
type: Type ← UnderType[TVType[mapper]];
computed: BOOL ← IsComputed[type];
stb: SymbolTableBase;
sei: SymbolIndex;
class: Class = TypeClass[type];
IF mapper = NIL THEN ERROR Error[reason: typeFault, type: type];
IF class = descriptor
OR class = longDescriptor
THEN {
ws: WordSequence = TVToWordSequence[mapper];
wsd: LONG POINTER TO DESCRIPTOR FOR ARRAY OF WORD = LOOPHOLE[@ws[0]];
wsld: LONG POINTER TO LONG DESCRIPTOR FOR ARRAY OF WORD = LOOPHOLE[wsd];
length: CARDINAL = IF class = descriptor THEN LENGTH[wsd^] ELSE LENGTH[wsld^];
type ← Range[type];
IF TVToCardinal[arg] >= length THEN ERROR Error[reason: rangeFault];
IF IsRemote[mapper]
THEN mapper ← TVForRemotePointerReferent[
remotePointer: [
world: GetWorld[mapper],
worldIncarnation: GetWorldIncarnation[mapper],
ptr:
IF class = descriptor
THEN LOOPHOLE[LONG[BASE[wsd^]], WorldVM.Address]
ELSE LOOPHOLE [BASE[wsld^], WorldVM.Address]],
type: type,
status: ReferentStatus[TVType[mapper]]]
ELSE mapper ← TVForPointerReferent [
ptr: IF class = descriptor THEN BASE[wsd^] ELSE BASE[wsld^],
type: type,
status: ReferentStatus[TVType[mapper]]]};
[stb, sei] ← GetTypeSymbols[type];
{
ENABLE
UNWIND => ReleaseSTB[stb];
eltTypeEi: SymbolIndex;
domainType: Type = Domain[type];
upperLimit: INT ← TVToLI[Last[domainType]];
domainOffset:
INT ←
IF EquivalentTypes[domainType,
CODE[
INTEGER]]
THEN 0
ELSE TVToLI[First[domainType]];
argValue: INT = TVToLI[arg];
bitOffset: INT;
bitsPerElement: CARDINAL;
tagEndOffset: INTEGER ← 0;
isPacked: BOOL ← FALSE;
isSequence: BOOL ← FALSE;
fd: tp.FieldDescriptor;
WITH stb
SELECT
FROM
t: SymbolTableBase.x =>
WITH ser: t.e.seb[t.e.UnderType[
NARROW[sei, SymbolIndex.x].e]]
SELECT
FROM
array => {isPacked ← ser.packed; eltTypeEi ← [x[ser.componentType]]};
sequence => {
isPacked ← ser.packed;
isSequence ← TRUE;
eltTypeEi ← [x[ser.componentType]];
Sequence begins in the word beyond the tag! Currently we have no way to find out what the offset is if the sequence is computed, so we assume 0 (which is wrong for some sequences).
tagEndOffset ←
IF computed
THEN 0
ELSE (t.e.seb[ser.tagSei].idInfo + t.e.seb[ser.tagSei].idValue)};
ENDCASE => ERROR Error[reason: typeFault, type: TVType[mapper]];
t: SymbolTableBase.y =>
WITH ser: t.e.seb[t.e.UnderType[
NARROW[sei, SymbolIndex.y].e]]
SELECT
FROM
array => {isPacked ← ser.packed; eltTypeEi ← [y[ser.componentType]]};
sequence => {
isPacked ← ser.packed;
isSequence ← TRUE;
eltTypeEi ← [y[ser.componentType]];
See above comment about sequences...
tagEndOffset ←
IF computed
THEN 0
ELSE (t.e.seb[ser.tagSei].idInfo + t.e.seb[ser.tagSei].idValue)};
ENDCASE => ERROR Error[reason: typeFault, type: TVType[mapper]];
ENDCASE => ERROR;
IF isSequence
AND computed
THEN
RRA: This special value has been squirrelled away by IndexToTV!
tagEndOffset ← GetSequenceOffset[type] * bitsPerWord;
IF
NOT computed
THEN {
IF isSequence
THEN
upperLimit ← TVToLI[Tag[mapper]] - 1;
IF (~InRange[domainType, arg]
OR argValue > upperLimit)
THEN
extra check for sequences!
ERROR Error[reason: rangeFault];
};
WITH stb
SELECT
FROM
t: SymbolTableBase.x =>
bitsPerElement ← t.e.BitsPerElement[type: NARROW[eltTypeEi, SymbolIndex.x].e, packed: isPacked];
t: SymbolTableBase.y =>
bitsPerElement ← t.e.BitsPerElement[type: NARROW[eltTypeEi, SymbolIndex.y].e, packed: isPacked];
ENDCASE => ERROR;
bitOffset ← tagEndOffset + (argValue - domainOffset) * bitsPerElement;
now adjust bitOffset if the entire mapper is smaller than a word and in an allocated object
IF (class # descriptor)
AND (class # longDescriptor)
AND (NOT isSequence) AND (NOT Embedded[mapper])
THEN {
bitsForTV: LONG CARDINAL ← 0;
[bitsForTV,,] ← tp.BitsForType[type];
IF bitsForTV < bitsPerWord
THEN
bitOffset ← bitOffset + bitsPerWord - ShortenLongCardinal[bitsForTV];
fd ← BuildRecordFieldDescriptor [
mapper,
bitOffset,
bitsPerElement,
(
WITH stb
SELECT
FROM
t: SymbolTableBase.x =>t.e.BitsForType[type: NARROW[eltTypeEi, SymbolIndex.x].e],
t: SymbolTableBase.y =>t.e.BitsForType[type: NARROW[eltTypeEi, SymbolIndex.y].e],
ENDCASE => ERROR)];
{
-- for defn of mapperTVRec
mapperTVRec: REF TypedVariableRec = NARROW[mapper, REF TypedVariableRec];
WITH h: mapperTVRec.head
SELECT
FROM
constant, remoteConstant => {
-- can't have an embedded const tvrec (sigh)
ws: WordSequence;
value: WordSequence
=
WITH mtvr: mapperTVRec
SELECT
FROM
constant => mtvr.value,
ENDCASE => ERROR;
WITH ee: fd
SELECT
FROM
small => {
words: CARDINAL = IF ee.field.bitCount <= Basics.bitsPerWord THEN 1 ELSE 2;
ws ← NEW[WordSequenceRecord[words]];
IF words = 1
THEN
LOOPHOLE[@ws[0],
LONG
POINTER
TO
CARDINAL]^
← RTCommon.FetchField[@value[0] + ee.wordOffset, ee.field]
ELSE
LOOPHOLE[@ws[0],
LONG
POINTER
TO
LONG CARDINAL]^
← RTCommon.FetchFieldLong[@value[0] + ee.wordOffset, ee.field];
};
large => {
words: CARDINAL = ee.size;
ws ← NEW[WordSequenceRecord[words]];
FOR i:
CARDINAL
IN [0..words)
DO
ws[i] ← value[i + ee.wordOffset]
ENDLOOP;
};
ENDCASE => ERROR;
embeddedTV ←
NEW[TypedVariableRec ← [
referentType: [Range[type]],
head: h,
status: mapperTVRec.status,
field: constant[value: ws]]];
}
ENDCASE =>
embeddedTV ←
NEW[TypedVariableRec ← [
referentType: [Range[type]],
head: h,
status: mapperTVRec.status,
field: embedded[fd: fd]]];
}; -- end scope of mapperTVRec defn
}; -- end ENABLE UNWIND
ReleaseSTB[stb];
Fetch:
PUBLIC
SAFE
PROC[tv: TypedVariable
--rope--, index:
INT]
RETURNS [
CHAR] =
TRUSTED {
type: Type = TVType[tv];
SELECT LocalUnderClass[type]
FROM
rope =>
IF IsRemote[tv]
THEN RETURN[RemoteRope.RemoteFetch[tv, index]]
ELSE RETURN[Rope.Fetch[TVToName[tv], index]];
ENDCASE;
ERROR Error[reason: typeFault, type: type]};
OctalRead:
PUBLIC
SAFE
PROC
[tv: TypedVariable, offset: INT] RETURNS[ans: CARDINAL] = TRUSTED {
addr: tp.ValueAddress = tp.GetValueAddress[tv];
WITH t: addr
SELECT
FROM
constant => ans ← t.value[offset];
pointer => ans ← LOOPHOLE[t.ptr + offset, LONG POINTER TO CARDINAL]^;
remotePointer => ans ←
RTTypesRemotePrivate.GetRemoteWord[[
world: GetWorld[tv],
worldIncarnation: GetWorldIncarnation[tv],
ptr: t.ptr.ptr + offset]];
copiedRemoteObject => ans ← LOOPHOLE[t.ptr + offset, LONG POINTER TO CARDINAL]^;
ENDCASE => ERROR;
};
Length:
PUBLIC
SAFE
PROC
[tv: TV --sequence, rope, descriptor, longDescriptor--] RETURNS[INT] = TRUSTED {
type: Type = UnderType[TVType[tv]];
SELECT TypeClass[type]
FROM
sequence =>
RETURN[GetSequenceLength[tv]];
rope =>
IF IsRemote[tv]
THEN RETURN[RemoteRope.RemoteLength[tv]]
ELSE RETURN[Rope.Length[TVToName[tv]]];
descriptor => {
ws: WordSequence = TVToWordSequence[tv];
RETURN[
LENGTH[
LOOPHOLE[
@ws[0],
LONG POINTER TO DESCRIPTOR FOR ARRAY OF WORD]^]]};
longDescriptor => {
ws: WordSequence = TVToWordSequence[tv];
RETURN[
LENGTH[
LOOPHOLE[
@ws[0],
LONG POINTER TO LONG DESCRIPTOR FOR ARRAY OF WORD]^]]};
ENDCASE =>
ERROR Error[reason: typeFault, type: type];
Loophole:
PUBLIC
PROC
[tv: TypedVariable, type: Type, tag: TypedVariable ← NIL] RETURNS[TypedVariable] = {
raises typeFault, badTV
NOTE no size check. You're on your own.
variantClass: Class = VariableType[type].c;
IF tag #
NIL
AND variantClass # union
AND variantClass # sequence
THEN ERROR Error[reason: typeFault, type: type, msg: "non-NIL tag makes no sense"];
WITH tv
SELECT
FROM
tvr:
REF TypedVariableRec =>
WITH tvr: tvr
SELECT
FROM
entire =>
RETURN[
NEW[TypedVariableRec ← [
referentType: [type, tag],
head: tvr.head,
status: tvr.status,
field: entire[]]]];
embedded =>
RETURN[
NEW[TypedVariableRec ← [
referentType: [type, tag],
head: tvr.head,
status: tvr.status,
field: embedded[fd: tvr.fd]]]];
constant =>
RETURN[
NEW[TypedVariableRec ← [
referentType: [type, tag],
head: tvr.head,
status: tvr.status,
field: constant[value: tvr.value]]]];
ENDCASE => ERROR;
ENDCASE => ERROR;
};
ConcreteRef:
PUBLIC
SAFE
PROC
[tv: TypedVariable--ref any--] RETURNS[ans: TypedVariable ← NIL] = TRUSTED {
type: Type ← UnderType[TVType[tv]];
class: Class ← TypeClass[type];
target: Type ← nullType;
IF class = nil OR TVToLC[tv] = 0 THEN RETURN[NIL];
IF class = atom OR class = rope OR class = list OR class = countedZone THEN RETURN[tv];
IF class # ref THEN ERROR Error[reason: typeFault, type: type];
IF TypeClass[Range[type]] # any THEN RETURN[tv];
SELECT
TRUE
FROM
IsAtom[tv] => target ← CODE[ATOM];
IsRope[tv] => target ← CODE[ROPE];
ENDCASE => {
realSourceRangeType: Type;
IF IsRemote[tv]
THEN {
r: RemoteRef = [
world: GetWorld[tv], worldIncarnation: GetWorldIncarnation[tv], ref: TVToLC[tv]];
realSourceRangeType ← RTTypesRemotePrivate.GetRemoteReferentType[r]}
ELSE realSourceRangeType ← GetReferentType[TVToRef[tv]];
IF LocalUnderClass[realSourceRangeType] = structure
AND NComponents[UnderType[realSourceRangeType]] = 2
AND LocalUnderClass[IndexToType[realSourceRangeType, 2]] = list
THEN target ← IndexToType[realSourceRangeType, 2];
};
IF target # nullType THEN RETURN [Coerce[tv, target]];
ERROR Error[
reason: notImplemented,
msg: "ConcreteRef for other than ATOM, ROPE or LIST targets"];
};
IsNil:
PUBLIC
SAFE
PROC[tv: TypedVariable
--address--]
RETURNS [
BOOL] =
TRUSTED {
SELECT LocalUnderClass[TVType[tv]]
FROM
relativePointer, atom, rope, list, ref, pointer, longPointer, basePointer, countedZone, uncountedZone, process, procedure, signal, error, program, port =>
RETURN[TVToLC[tv] = 0];
nil => RETURN[TRUE];
descriptor => {
ws: WordSequence = TVToWordSequence[tv];
RETURN[
NIL =
BASE[
LOOPHOLE
[@ws[0], LONG POINTER TO DESCRIPTOR FOR ARRAY OF WORD]^]]};
longDescriptor => {
ws: WordSequence = TVToWordSequence[tv];
RETURN[
NIL =
BASE[
LOOPHOLE
[@ws[0], LONG POINTER TO LONG DESCRIPTOR FOR ARRAY OF WORD]^]]};
ENDCASE => ERROR Error[typeFault];
};
Referent:
PUBLIC
SAFE
PROC
[
tv: TypedVariable, --ref, list, pointer, longPointer, basePointer, relativePointer--
base: TypedVariable ←
NIL
base non-nil only if ref is a relativePointer. UNSAFE in this case.
]
RETURNS[TypedVariable] = TRUSTED {
type: Type ← TVType[tv];
referentType: Type ← Range[type]; -- raises Error[typeFault]
status: Status ← mutable;
ptr: Pointer;
stb: SymbolTableBase;
sei: SymbolIndex;
[stb, sei] ← GetTypeSymbols[type];
WITH stb
SELECT
FROM
t: SymbolTableBase.x => {
ENABLE UNWIND => ReleaseSTB[stb];
WITH ser: t.e.seb[t.e.UnderType[
NARROW[sei, SymbolIndex.x].e]]
SELECT
FROM
long =>
WITH ser1: t.e.seb[t.e.UnderType[ser.rangeType]]
SELECT
FROM
ref => IF ser1.readOnly THEN status ← readOnly;
ENDCASE => ERROR Error[reason: typeFault, type: type];
ref => IF ser.readOnly THEN status ← readOnly;
relative => NULL;
ENDCASE => ERROR Error[reason: typeFault, type: type]};
t: SymbolTableBase.y => {
ENABLE UNWIND => ReleaseSTB[stb];
WITH ser: t.e.seb[t.e.UnderType[
NARROW[sei, SymbolIndex.y].e]]
SELECT
FROM
long =>
WITH ser1: t.e.seb[t.e.UnderType[ser.rangeType]]
SELECT
FROM
ref => IF ser1.readOnly THEN status ← readOnly;
ENDCASE => ERROR Error[reason: typeFault, type: type];
ref => IF ser.readOnly THEN status ← readOnly;
relative => NULL;
ENDCASE => ERROR Error[reason: typeFault, type: type]};
ENDCASE => ERROR;
ReleaseSTB[stb];
IF referentType = unspecType THEN ERROR Error[reason: typeFault, type: referentType];
IF IsRemote[tv]
THEN
SELECT LocalUnderClass[type]
FROM
relativePointer => {
world: World = GetWorld[tv];
ptr: RemotePointer = [
world: world,
worldIncarnation: CurrentIncarnation[world],
ptr: TVToLC[base] + TVToCardinal[tv]];
NOTE assumption that MDS is in the same place
IF
NOT LocalUnderClass[TVType[base]] = basePointer
THEN ERROR Error[reason: typeFault, type: TVType[base]];
RETURN[TVForRemotePointerReferent
[remotePointer: ptr, type: referentType, status: status]]};
ref, list => {
world: World = GetWorld[tv];
ref: RemoteRef = [world: world,
worldIncarnation: CurrentIncarnation[world],
ref: TVToLC[tv]];
RETURN[TVForRemoteReferent[remoteRef: ref, status: status]]};
pointer => {
world: World = GetWorld[tv];
ptr: RemotePointer = [
world: world,
worldIncarnation: CurrentIncarnation[world],
ptr: Long[world: world, addr: TVToCardinal[tv]]];
NOTE assumption that MDS is in the same place
IF LocalUnderClass[referentType] = opaque
THEN ERROR Error[reason: typeFault, type: referentType];
RETURN[TVForRemotePointerReferent
[remotePointer: ptr, type: referentType, status: status]]};
longPointer, basePointer => {
world: World = GetWorld[tv];
IF LocalUnderClass[referentType] = opaque
THEN ERROR Error[reason: typeFault, type: referentType];
RETURN[TVForRemotePointerReferent [
remotePointer: [world: world,
worldIncarnation: CurrentIncarnation[world],
ptr: TVToLC[tv]],
type: referentType,
status: status]]};
ENDCASE => ERROR -- end IsRemote[tv]
ELSE
-- local tv
SELECT LocalUnderClass[type]
FROM
relativePointer => {
IF NOT LocalUnderClass[TVType[base]] = basePointer
THEN ERROR Error[reason: typeFault, type: TVType[base]];
ptr ← LOOPHOLE[TVToLC[base] + TVToCardinal[tv], Pointer];
RETURN[TVForPointerReferent[ptr: ptr, type: referentType, status: status]]};
ref, list => RETURN[TVForReferent[ref: TVToRef[tv], status: status]];
pointer => {
ptr ← LONG[LOOPHOLE[TVToCardinal[tv], POINTER]];
IF LocalUnderClass[referentType] = opaque
THEN ERROR Error[reason: typeFault, type: referentType];
RETURN[TVForPointerReferent[
ptr: ptr,
type: referentType,
status: status]]};
longPointer, basePointer => {
ptr ← LOOPHOLE[TVToLC[tv], Pointer];
IF LocalUnderClass[referentType] = opaque
THEN ERROR Error[reason: typeFault, type: referentType];
RETURN[TVForPointerReferent[
ptr: ptr,
type: referentType,
status: status]]};
ENDCASE => ERROR;
}; -- end Referent
Coerce:
PUBLIC
SAFE
PROC
[tv: TypedVariable, targetType: Type] RETURNS[newTV: TypedVariable] = TRUSTED {
type: Type;
{-- block for common errors
Raises typeFault, rangeFault. COPIES unless types are equivalent.
tvr: REF TypedVariableRec; -- utility
targetClass, sourceClass: Class;
DO
This loop is here to provide for stripping off of record layers for single-component records and the handling of REF to opaque types.
type ← TVType[tv];
IF type = targetType THEN RETURN[tv];
IF EquivalentTypes[type, targetType] THEN GO TO loophole;
targetClass ← LocalUnderClass[targetType];
sourceClass ← LocalUnderClass[type];
IF sourceClass = record
AND AMTypes.NComponents[type] = 1
THEN {
strip off excess layers of record
element: TV ← IndexToTV[tv, 1];
SELECT LocalUnderClass[TVType[element]]
FROM
union => element ← Variant[element];
sequence => GO TO error;
ENDCASE;
tv ← element;
LOOP;
};
IF sourceClass = nil
OR (sourceClass = ref
AND TVToLC[tv] = 0)
THEN
NIL is handled specially (we are overly generous here with different types of NIL)
SELECT targetClass
FROM
list, procedure, signal, error, program, port, ref, pointer, longPointer, rope, atom, unspecified, countedZone, uncountedZone, process, nil, descriptor, longDescriptor, basePointer, relativePointer =>
RETURN [New[targetType, readOnly]];
ENDCASE => GO TO error;
IF sourceClass = ref
AND LocalUnderClass[Range[type]] = opaque
THEN {
This is a REF to an opaque type. If the target type is REF concrete, then we may win by looking at the referent type carried by the object itself.
tv ← Loophole[tv, CODE[REF ANY]];
LOOP;
};
EXIT;
ENDLOOP;
SELECT targetClass
FROM
unspecified =>
unspecified matches anything of size = 1
IF TVSize[tv] = 1 THEN GO TO loophole ELSE GO TO error;
procedure => {
the target type class
SELECT sourceClass
FROM
-- look at the source type
procedure => {
IF LocalUnderClass[Domain[targetType]] = any
AND LocalUnderClass[Range[targetType]] = any
THEN {
assignment of a proc to a PROC ANY ANY; copy it
IF IsRemote[tv]
THEN newTV ← NEW[TypedVariableRec ← [
referentType: [targetType],
head: [copiedRemoteObject [
world: GetWorld[tv],
worldIncarnation: GetWorldIncarnation[tv],
copy: NEW[WordSequenceRecord[1]]]],
status: mutable,
field: entire[]]]
ELSE newTV ← New[type: targetType];
Assign[lhs: newTV, rhs: Loophole[tv, targetType]];
}
ELSE GO TO error;
};
nil => RETURN[NIL]; -- NIL conforms to any PROC type
ENDCASE => GO TO error;
};
ref, list, atom, rope, countedZone => {
the target type class
targetRangeType: Type ← nullType;
sourceRangeType: Type ← nullType;
realSourceRangeType: Type ← nullType;
narrowToAtomOrRopeOrZone: BOOL ← FALSE;
widenFromAtomOrRopeOrZone: BOOL ← FALSE;
SELECT sourceClass
FROM
-- look at the source type
ref, list, atom, rope, countedZone => NULL;
ENDCASE => GO TO error;
SELECT targetClass
FROM
ref, list => targetRangeType ← Range[targetType];
ENDCASE;
SELECT sourceClass
FROM
ref, list => {
sourceRangeType ← Range[UnderType[type]];
IF IsRemote[tv]
THEN {
r: RemoteRef = [world: GetWorld[tv],
worldIncarnation: GetWorldIncarnation[tv],
ref: TVToLC[tv]];
realSourceRangeType ← RTTypesRemotePrivate.GetRemoteReferentType[r]}
ELSE realSourceRangeType ← GetReferentType[TVToRef[tv]]};
ENDCASE;
SELECT targetClass
FROM
atom, rope, countedZone => {
check that a REF ANY tv represents an atom or rope, respectively
IF sourceClass # ref OR sourceRangeType # anyType THEN GO TO badRange;
SELECT targetClass
FROM
atom =>
IF
NOT EquivalentTypes[realSourceRangeType,
CODE[AtomPrivate.AtomRec]]
THEN GO TO badRange;
rope =>
IF
NOT EquivalentTypes[realSourceRangeType,
CODE[Rope.RopeRep]]
THEN GO TO badRange;
countedZone =>
NULL;
IF NOT EquivalentTypes[realSourceRangeType, CODE[RTZones.ZoneRec]]
THEN GO TO badRange;
ENDCASE => ERROR;
narrowToAtomOrRopeOrZone ← TRUE;
};
SELECT sourceClass
FROM
atom, rope, countedZone => {
widenFromAtomOrRopeOrZone
← targetClass = ref
AND (targetRangeType = unspecType OR targetRangeType = anyType);
IF NOT widenFromAtomOrRopeOrZone THEN GO TO badRange};
IF narrowToAtomOrRopeOrZone
OR widenFromAtomOrRopeOrZone
OR targetRangeType = unspecType --widen--
OR targetRangeType = anyType --widen--
OR sourceRangeType = nullType --NIL conforms to any ref target type--
OR AsGoodAs[lhsType: targetRangeType, rhsType: sourceRangeType] --narrow--
OR ((sourceClass = ref
OR sourceClass = list)
AND AsGoodAs[lhsType: targetRangeType, rhsType: realSourceRangeType]) --narrow--
THEN {
create a new TV of the specified targetType with the specified value
IF IsRemote[tv]
THEN {
world: World = GetWorld[tv];
ws: WordSequence = NEW[WordSequenceRecord[2]];
LOOPHOLE[@ws[0], LONG POINTER TO LONG CARDINAL]^ ← TVToLC[tv];
newTV ←
NEW[TypedVariableRec ← [
referentType: [targetType],
head: [copiedRemoteObject [
world: world,
worldIncarnation: CurrentIncarnation[world],
copy: ws]],
status: readOnly,
field: entire[]]];
}
ELSE {
logically, the value of tv (a REF, LIST, ATOM, or ROPE)
newTV ← New[type: targetType, status: readOnly];
tvr ← NARROW[newTV, REF TypedVariableRec];
WITH hd: tvr.head
SELECT
FROM
reference => LOOPHOLE[hd.ref, REF REF ANY]^ ← TVToRef[tv];
ENDCASE => ERROR}}
ELSE GO TO badRange};
subrange, character, enumerated, integer, cardinal, longInteger, longCardinal => {
li: INT = TVToLI[tv];
SELECT targetClass
FROM
longCardinal => IF li < 0 THEN GO TO badRange;
cardinal => IF li < 0 OR li > LAST[CARDINAL] THEN GO TO badRange;
longInteger => {};
integer => IF li < FIRST[INTEGER] OR li > LAST[INTEGER] THEN GO TO badRange;
character => IF li < 0 OR li > 377B THEN GO TO badRange;
ENDCASE =>
IF li < TVToLI[First[targetType]]
OR TVToLI[Last[targetType]] < li
THEN GO TO badRange;
newTV ← New[type: targetType, status: mutable];
SetTVFromLI[newTV, li];
NARROW[newTV, REF TypedVariableRec].status ← readOnly;
};
real => {
li: INT = TVToLI[tv];
ref: REF REAL ← NEW[REAL ← li];
RETURN [AMBridge.TVForReadOnlyReferent[ref]];
};
ENDCASE => GO TO error;
EXITS
loophole => RETURN [Loophole[tv, targetType]];
error => ERROR Error[reason: typeFault, type: targetType];
badRange => ERROR Error[reason: rangeFault]
InRange:
PUBLIC
SAFE
PROC[type: Type
--subrange--, groundTV: TypedVariable]
RETURNS[val: BOOL ← TRUE] = TRUSTED {
[] ← Coerce[groundTV, type ! Error => IF reason = rangeFault THEN val ← FALSE];
};
Next:
PUBLIC
SAFE
PROC[tv: TypedVariable
--enumerated, subrange, basic--]
RETURNS[TypedVariable] = TRUSTED {
val: LONG INTEGER = TVToLI[tv];
type: Type = TVType[tv];
newTV: TypedVariable;
IF val = TVToLI[Last[type]] THEN RETURN[NIL];
newTV ← New[type];
SetTVFromLC[newTV, LOOPHOLE[val + 1, LONG CARDINAL]]; -- NOTE mach dep enum?
RETURN[newTV]};
Procedures private to this module
LocalUnderClass:
SAFE
PROC [type: Type]
RETURNS [class: Class] =
TRUSTED {
class ← TypeClass[UnderType[type]];
};
LastComponent:
PROC
[tv: TypedVariable, type: Type ← nullType] RETURNS [TypedVariable] = {
IF type = nullType THEN type ← TVType[tv];
RETURN [IndexToTV[tv, NComponents[type]]]};
Constant:
PROC[tv: TypedVariable]
RETURNS[ans:
BOOL ←
FALSE] = {
WITH tv
SELECT
FROM
rtr:
REF TypedVariableRec =>
WITH etr: rtr
SELECT
FROM
constant => ans ← TRUE;
ENDCASE;
ENDCASE;
};
Embedded:
PROC[tv: TypedVariable]
RETURNS[ans:
BOOL ←
FALSE] = {
WITH tv
SELECT
FROM
rtr:
REF TypedVariableRec =>
WITH etr: rtr
SELECT
FROM
embedded => ans ← TRUE;
ENDCASE;
ENDCASE;
BuildRecordFieldDescriptor:
PUBLIC
PROC
[parentTV: TypedVariable, fieldBitOffset, fieldBits, bitsForType: INT]
RETURNS[fD: tp.FieldDescriptor] = {
BuildRecordFieldDescriptor is used to build FieldDescriptors for components of TVs. fieldBitOffset and fieldBits specify the component's container location and size relative to the container holding parentTV's value. If the component is smaller than a word, bitsForType specifies its size, which may be smaller than the size of the component's container (if bitsForType >= bitsPerWord, the component size is the same as the container size). The result of BuildRecordFieldDescriptor describes an embedded field WRT parentTV's head wherein the bits of the component reside. Generally, an embedded field of a TV describes where WRT its head the bits of its value reside.
fD ←
IF bitsForType < bitsPerWord
THEN BuildSmallFieldDescriptor[fieldBitOffset + fieldBits - bitsForType, bitsForType]
ELSE BuildLargeFieldDescriptor[fieldBitOffset / bitsPerWord, fieldBits / bitsPerWord];
IF parentTV = NIL THEN RETURN;
adjust offsets relative to parent.
WITH parentTV
SELECT
FROM
parentTr:
REF TypedVariableRec =>
WITH parentT: parentTr
SELECT
FROM
embedded=> {
fD.wordOffset ← fD.wordOffset + parentT.fd.wordOffset;
WITH parentF: parentT.fd
SELECT
FROM
small =>
WITH f: fD
SELECT
FROM
small=> f.field.bitFirst ← f.field.bitFirst + parentF.field.bitFirst;
ENDCASE => ERROR;
ENDCASE};
ENDCASE;
ENDCASE => ERROR;
BuildSmallFieldDescriptor:
PROC[bitOffset, bitCount:
INT]
RETURNS[small tp.FieldDescriptor] = INLINE {
RETURN[tp.FieldDescriptor[
wordOffset: ShortenLongInteger[bitOffset / bitsPerWord],
extent: small[field: [bitFirst: ShortenLongInteger
[bitOffset MOD bitsPerWord],
bitCount: ShortenLongInteger[bitCount]]]]]};
BuildLargeFieldDescriptor:
PROC[wordOffset, nWords:
INT]
RETURNS[large tp.FieldDescriptor] = INLINE {
RETURN[tp.FieldDescriptor[
wordOffset: ShortenLongInteger[wordOffset],
extent: large[size: ShortenLongInteger[nWords]]]]};
AsGoodAs:
PROC[rhsType, lhsType: Type]
RETURNS[
BOOL] = {
copied in AMVariablesImpl
NOTE freely conforms = Equivalent for now
RETURN[EquivalentTypes[rhsType, lhsType]];
};
END.