[Cyan]<Cedar6.1>AMTypes>RTTypedVariablesImpl.mesa!2

RTTypedVariablesImpl.Mesa

Russ Atkinson (RRA) June 10, 1986 9:48:15 am 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, Coerce, Domain, Error, First, Globals, GroundStar, IndexToName, IndexToType, IsAtom, IsComputed, IsOverlaid, IsRope, Last, Locals, NameToIndex, NComponents, Range, ReferentStatus, Size, Status, TVStatus, TVType, TypeClass, UnderType, VariableType, TV, 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],

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, RTTypesPrivate, RTCommon, SafeStoragePrivate, RTSymbolDefs, RTSymbolOps, RTSymbols, RTTCache, SafeStorage, RTTypesRemotePrivate, WorldVM;

T Y P E S

Pointer: TYPE = LONG POINTER;

ROPE: TYPE = Rope.ROPE;

TypedVariableRec: TYPE = RTTypesPrivate.TypedVariableRec;

TypedVariableRef: TYPE = REF TypedVariableRec;

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: TV] = 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, TypedVariableRef].status ← mutable;

Assign[lhs: newTag, rhs: tag];

NARROW[newTag, TypedVariableRef].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: TypedVariableRef = 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: TypedVariableRef ← NARROW[Tag[LastComponent[newTV, type]]];

IF newTag # NIL THEN {

newTag.status ← mutable;

Assign[lhs: newTag, rhs: tag];

newTag.status ← readOnly;

};

RETURN[newTV];

};

TVTag: PROC [tv: TV] RETURNS [TV] = {

COPIED in AMVariablesImpl

RETURN[NARROW[tv, TypedVariableRef].referentType.tag];

};

TVSize: PUBLIC SAFE PROC [tv: TV] RETURNS [INT--words--] = TRUSTED {

Could overflow

lots of changes by RRA for speed and generality

type: Type = UnderType[TVType[tv]];

vClass: Class ← nil;

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, procedure, signal, error, program, port => RETURN [1];

ENDCASE;

RETURN[Size[type: type]];

};

Tag: PUBLIC SAFE PROC [tv: TV--union, sequence--] RETURNS [ans: TV] = 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 RTTypesPrivate.TypedVariableRec =>

WITH etr: rtr SELECT FROM

constant => {

ntv: TV ← AMBridge.TVForReadOnlyReferent[etr.value];

tv ← AMBridge.Loophole[ntv, type];

kludgeBits ← bitsPerWord;

};

ENDCASE;

ans ← NEW[TypedVariableRec ← [

referentType: [Domain[type]],

head: (WITH tv SELECT FROM

tr: TypedVariableRef => 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: TV--union--] RETURNS [ans: TV ← 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];

RTTypesPrivate.ComponentISEI[type, NameToIndex[type, TVToName[Tag[tv]]], p];

};

IndexToTV: PUBLIC SAFE PROC [tv: TV--record, structure--, index: Index] RETURNS [TV] = TRUSTED {

[1..NComponents[TVType[tv]]]

cType: Type;

type: Type ← UnderType[TVType[tv]];

et: TypedVariableRef;

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 - 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: RTTypesPrivate.GetIdConstantValue[tv, stb, isei]]

]]

ELSE et ← NEW[TypedVariableRec ← [

referentType: [cType, TVTag[tv]],

head: [constant[]],

status: const,

field: constant[value: RTTypesPrivate.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: RTTypesPrivate.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: TypedVariableRef =>

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: TypedVariableRef => 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]];

};

}};

Begin IndexToTV Here

[bitsForTV, argRec, interfaceRec] ← RTTypesPrivate.BitsForType[type];

RTTypesPrivate.RecordComponentISEI[type, index, BuildEmbeddedTV];

RETURN[et];

};

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: TV--type--] RETURNS [rtn: Type] = TRUSTED {

raises typeFault

type: Type = UnderType[TVType[tv]];

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: TV--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: TV] 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, since it relies on the print name of an atom being at offset 0 in the remote world. Life is hard.

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];

subrange => {

If this tv is for a subrange, then it may be a subrange of an enumeration, so we coerce it to the type of the (potential) enumeration, and recurse. This should only recurse one level at most.

ans ← TVToName[AMTypes.Coerce[tv, AMTypes.GroundStar[type]]];

};

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 ← RTTypesPrivate.PDToName[LOOPHOLE[TVToProc[tv], ProcDesc]];

signal, error =>

IF IsRemote[tv]

THEN ans ← RemoteSEDToName[TVToRemoteSignal[tv]]

ELSE ans ← RTTypesPrivate.SEDToName[LOOPHOLE[TVToSignal[tv], SignalDesc]];

globalFrame =>

IF IsRemote[tv]

THEN ans ← RemoteGFHToName[RemoteGFHFromTV[tv]]

ELSE ans ← RTTypesPrivate.GFHToName[GFHFromTV[tv]];

ENDCASE;

};

Apply: PUBLIC SAFE PROC [mapper: TV, arg: TV] RETURNS [embeddedTV: TV] = TRUSTED {

mapper must have class in {array, sequence, descriptor, longDescriptor}

type: Type ← UnderType[TVType[mapper]];

computed: BOOL ← IsComputed[type];

stb: SymbolTableBase;

sei: SymbolIndex;

IF mapper = NIL THEN ERROR Error[reason: typeFault, type: type];

SELECT class FROM

descriptor, longDescriptor => {

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]]]};

ENDCASE;

[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: RTTypesPrivate.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,,] ← RTTypesPrivate.BitsForType[type];

IF bitsForTV < bitsPerWord THEN

bitOffset ← bitOffset + bitsPerWord - 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: TypedVariableRef = NARROW[mapper, TypedVariableRef];

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]]];

};

ReleaseSTB[stb];

};

Fetch: PUBLIC SAFE PROC [tv: TV--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: TV, offset: INT] RETURNS [ans: CARDINAL] = TRUSTED {

addr: RTTypesPrivate.ValueAddress = RTTypesPrivate.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] 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: TV, type: Type, tag: TV ← NIL] RETURNS [TV] = {

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: TypedVariableRef =>

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;

};

ConcreteRef: PUBLIC SAFE PROC [tv: TV] RETURNS [ans: TV ← NIL] = TRUSTED {

tv must be for a REF ANY

type: Type ← UnderType[TVType[tv]];

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: TV--address--] RETURNS [BOOL ← FALSE] = 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;

};

Referent: PUBLIC SAFE PROC [ tv: TV, base: TV ← NIL] RETURNS [TV ← NIL] = TRUSTED {

type: Type ← TVType[tv];

referentType: Type ← Range[type]; -- raises Error[typeFault]

status: Status ← mutable;

ptr: Pointer;

stb: SymbolTableBase;

sei: SymbolIndex;

CauseFault: PROC = {ERROR Error[reason: typeFault, type: type]};

BadReferent: PROC = {ERROR Error[reason: typeFault, type: referentType]};

[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 => CauseFault[]};

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 => CauseFault[]};

ENDCASE => ERROR;

ReleaseSTB[stb];

IF referentType = unspecType THEN BadReferent[];

IF IsRemote[tv]

THEN {

SELECT LocalUnderClass[type] FROM

relativePointer => {

world: World = GetWorld[tv];

ptr: RemotePointer = [

world: world,

worldIncarnation: CurrentIncarnation[world],

ptr: TVToLC[base] + TVToLC[tv]];

NOTE assumption that MDS is in the same place

bType: Type = TVType[base];

IF NOT LocalUnderClass[bType] = basePointer THEN

ERROR Error[reason: typeFault, type: bType];

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 BadReferent[];

RETURN[TVForRemotePointerReferent

[remotePointer: ptr, type: referentType, status: status]]};

longPointer, basePointer => {

world: World = GetWorld[tv];

IF LocalUnderClass[referentType] = opaque THEN BadReferent[];

RETURN[TVForRemotePointerReferent [

remotePointer: [world: world,

worldIncarnation: CurrentIncarnation[world],

ptr: TVToLC[tv]],

type: referentType,

status: status]]};

ENDCASE;

}

ELSE {

SELECT LocalUnderClass[type] FROM

relativePointer => {

bType: Type = TVType[base];

IF NOT LocalUnderClass[bType] = basePointer THEN

ERROR Error[reason: typeFault, type: bType];

ptr ← LOOPHOLE[TVToLC[base] + TVToLC[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 BadReferent[];

RETURN[TVForPointerReferent[

ptr: ptr,

type: referentType,

status: status]]};

longPointer, basePointer => {

ptr ← LOOPHOLE[TVToLC[tv], Pointer];

IF LocalUnderClass[referentType] = opaque THEN BadReferent[];

RETURN[TVForPointerReferent[

ptr: ptr,

type: referentType,

status: status]]};

ENDCASE => ERROR;

};

CauseFault[];

};

Coerce: PUBLIC SAFE PROC [tv: TV, targetType: Type] RETURNS [newTV: TV] = TRUSTED {

type: Type;

{-- block for common errors

Raises typeFault, rangeFault. COPIES unless types are equivalent.

tvr: TypedVariableRef; -- utility

targetClass, sourceClass: Class;

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;

};

ENDCASE;

SELECT sourceClass FROM

atom, rope, countedZone => {

widenFromAtomOrRopeOrZone

← targetClass = ref

AND (targetRangeType = unspecType OR targetRangeType = anyType);

IF NOT widenFromAtomOrRopeOrZone THEN GO TO badRange};

ENDCASE;

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])

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, TypedVariableRef];

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, TypedVariableRef].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]

}}; -- end Coerce

InRange: PUBLIC SAFE PROC [type: Type, groundTV: TV] RETURNS [val: BOOL ← TRUE] = TRUSTED {

[] ← Coerce[groundTV, type ! Error => IF reason = rangeFault THEN val ← FALSE];

};

Next: PUBLIC SAFE PROC [tv: TV] RETURNS [new: TV] = TRUSTED {

val: INT = TVToLI[tv];

type: Type = TVType[tv];

IF val = TVToLI[Last[type]] THEN RETURN[NIL];

new ← New[type];

SetTVFromLC[new, LOOPHOLE[val + 1, LONG CARDINAL]]; -- NOTE mach dep enum?

};

Prev: PUBLIC SAFE PROC [tv: TV] RETURNS [new: TV] = TRUSTED {

val: INT = TVToLI[tv];

type: Type = TVType[tv];

IF val = TVToLI[First[type]] THEN RETURN[NIL];

new ← New[type];

SetTVFromLC[new, LOOPHOLE[val - 1, LONG CARDINAL]]; -- NOTE mach dep enum?

};

Procedures private to this module

LocalUnderClass: SAFE PROC [type: Type] RETURNS [class: Class] = TRUSTED {

class ← TypeClass[UnderType[type]];

};

LastComponent: PROC [tv: TV, type: Type ← nullType] RETURNS [TV] = {

IF type = nullType THEN type ← TVType[tv];

RETURN [IndexToTV[tv, NComponents[type]]];

};

Constant: PROC [tv: TV] RETURNS [ans: BOOL ← FALSE] = {

WITH tv SELECT FROM

rtr: TypedVariableRef =>

WITH etr: rtr SELECT FROM

constant => ans ← TRUE;

ENDCASE;

};

Embedded: PROC [tv: TV] RETURNS [ans: BOOL ← FALSE] = {

WITH tv SELECT FROM

rtr: TypedVariableRef =>

WITH etr: rtr SELECT FROM

embedded => ans ← TRUE;

ENDCASE;

};

BuildRecordFieldDescriptor: PUBLIC PROC [parentTV: TV, fieldBitOffset, fieldBits, bitsForType: INT] RETURNS [fD: RTTypesPrivate.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: TypedVariableRef =>

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 RTTypesPrivate.FieldDescriptor] = {

RETURN[RTTypesPrivate.FieldDescriptor[

wordOffset: bitOffset / bitsPerWord,

extent: small[field: [bitFirst: bitOffset MOD bitsPerWord, bitCount: bitCount]]]];

};

BuildLargeFieldDescriptor: PROC [wordOffset, nWords: INT] RETURNS [large RTTypesPrivate.FieldDescriptor] = {

RETURN[RTTypesPrivate.FieldDescriptor[wordOffset: wordOffset, extent: large[size: nWords]]];

};

AsGoodAs: PROC [rhsType, lhsType: Type] RETURNS [BOOL] = {

copied in AMVariablesImpl

NOTE freely conforms = Equivalent for now

RETURN[EquivalentTypes[rhsType, lhsType]];

};

END.