[Cyan]<Cedar6.0>Compiler>Pass3V.mesa!6

Pass3V.Mesa

Satterthwaite, April 9, 1986 5:41:43 pm PST

Russ Atkinson (RRA) March 6, 1985 10:44:46 pm PST

DIRECTORY

A3 USING [CanonicalType, LongPath, MarkedType, OperandType, TargetType, TypeForTree],

Alloc USING [Notifier],

ComData USING [idBOOL, ownSymbols, seAnon, textIndex, typeAtomRecord],

Copier USING [CopyUnion],

Log USING [Error, ErrorHti, ErrorSei, ErrorTree, Warning],

P3 USING [Attr, NarrowOp, NPUse, phraseNP, BaseTree, EnterType, Exp, FindSe, FirstId, ForceType, OpenPointer, PopCtx, PushCtx, PushHtCtx, PushRecordCtx, RAttr, Rhs, RPop, RPush, Scope, SealRefStack, SearchCtxList, TopCtx, UnsealRefStack, UpdateTreeAttr, UType, VoidExp],

P3S USING [ImplicitInfo, implicit, implicitRecord, safety],

SourceMap USING [Loc],

Symbols USING [Base, HTIndex, Type, ISEIndex, CSEIndex, RecordSEIndex, CTXIndex, HTNull, nullType, ISENull, CSENull, CTXNull, typeANY, typeTYPE, seType, ctxType],

SymbolOps USING [NextSe, NormalType, RCType, ReferentType, TypeForm, TypeLink, TypeRoot, UnderType],

Tree USING [Base, Index, Link, Map, Null, Scan, treeType],

TreeOps USING [GetHash, GetNode, ListHead, ListTail, OpName, PopTree, PushTree, PushNode, PushSe, ScanList, SetAttr, SetInfo, UpdateList],

Types USING [Equivalent];

Pass3V: PROGRAM

IMPORTS A3, Copier, Log, P3, P3S, SymbolOps, TreeOps, Types, dataPtr: ComData

EXPORTS P3 = {

OPEN SymbolOps, A3, P3, Symbols, TreeOps;

tables defining the current symbol table

tb: Tree.Base; -- tree base

seb: Symbols.Base; -- se table

ctxb: Symbols.Base; -- context table

VRNotify: PUBLIC Alloc.Notifier = {

called whenever the main symbol table is repacked

tb ← base[Tree.treeType]; seb ← base[seType]; ctxb ← base[ctxType]};

finding union and discriminated types

N. B. the following two entries cannot assume well-formed type links

VariantUnionType: PUBLIC PROC [type: Type] RETURNS [CSEIndex] = {

rType: CSEIndex = ConsType[type];

RETURN [WITH seb[rType] SELECT FROM

record =>

IF hints.variant

THEN ConsType[TypeForSe[UnionField[LOOPHOLE[rType, RecordSEIndex]]]]

ELSE typeANY,

ENDCASE => typeANY]};

SelectVariantType: PUBLIC PROC [type: Type, tag: HTIndex] RETURNS [sei: ISEIndex] = {

matched: BOOL;

vType: CSEIndex = VariantUnionType[type];

WITH seb[vType] SELECT FROM

union => [matched, sei] ← SearchCtxList[tag, caseCtx];

ENDCASE => matched ← FALSE;

IF ~matched THEN sei ← ISENull;

RETURN};

SequenceField: PUBLIC PROC [rSei: RecordSEIndex] RETURNS [ISEIndex] = {

sei: ISEIndex = UnionField[rSei];

RETURN [IF TypeForm[seb[sei].idType] = sequence THEN sei ELSE ISENull]};

auxiliary procedures (for avoiding UnderType when potentially unsafe)

UnionField: PROC [rSei: RecordSEIndex] RETURNS [ISEIndex] = {

sei, root, next: ISEIndex;

ctx: CTXIndex = seb[rSei].fieldCtx;

IF ctxb[ctx].ctxType = simple THEN

FOR sei ← ctxb[ctx].seList, next UNTIL sei = ISENull DO

next ← NextSe[sei];

IF next = ISENull THEN RETURN [sei];

ENDLOOP

ELSE { -- defined in another module, UnderType is safe

repeated: BOOL ← FALSE;

sei ← root ← ctxb[ctx].seList;

IF sei = ISENull THEN EXIT;

SELECT TypeForm[seb[sei].idType] FROM

union, sequence => RETURN [sei];

ENDCASE;

IF (sei ← NextSe[sei]) = root THEN EXIT;

ENDLOOP;

IF repeated THEN EXIT;

Copier.CopyUnion[seb[rSei].fieldCtx]; repeated ← TRUE;

ENDLOOP};

RETURN [dataPtr.seAnon]};

ResolveId: PROC [hti: HTIndex, ctx: CTXIndex] RETURNS [sei: ISEIndex] = {

currentCtx: CTXIndex = TopCtx[];

IF ctx = currentCtx THEN sei ← FindSe[hti].symbol

ELSE {PopCtx[]; sei ← ResolveId[hti, ctx]; PushCtx[currentCtx]};

RETURN};

TypeForSe: PROC [sei: ISEIndex] RETURNS [type: Type] = INLINE {

node: Tree.Index;

t: Tree.Link;

IF seb[sei].mark3 THEN RETURN [seb[sei].idType];

node ← seb[sei].idValue;

IF tb[node].name # decl THEN RETURN [typeTYPE];

t ← tb[node].son[2];

type ← WITH t SELECT FROM

hash => ResolveId[index, seb[sei].idCtx],

symbol => index,

subtree => tb[index].info,

ENDCASE => typeANY;

RETURN};

ConsType: PROC [type: Type] RETURNS [CSEIndex] = {

WITH se: seb[type] SELECT FROM

id =>

IF se.mark3 THEN

RETURN [IF se.idType # typeTYPE THEN typeANY ELSE ConsType[se.idInfo]]

ELSE {

node: Tree.Index = se.idValue;

RETURN [IF tb[node].name # typedecl

THEN typeANY

ELSE ConsType[ResolveTreeType[tb[node].son[2], se.idCtx]]]};

cons => RETURN [LOOPHOLE[type, CSEIndex]];

ENDCASE => ERROR};

ResolveTreeType: PROC [t: Tree.Link, ctx: CTXIndex] RETURNS [type: Type] = {

WITH t SELECT FROM

hash => type ← ResolveId[index, ctx];

symbol => type ← index;

subtree => {

node: Tree.Index = index;

type ← IF tb[node].info # nullType

THEN tb[node].info

ELSE

SELECT tb[node].name FROM

discrimTC =>

WITH tb[node].son[2] SELECT FROM

hash => SelectVariantType[ResolveTreeType[tb[node].son[1], ctx], index],

ENDCASE => ERROR,

ENDCASE => ERROR};

ENDCASE => ERROR;

RETURN};

type discrimination

DiscriminatedType: PUBLIC PROC [baseType: CSEIndex, t: Tree.Link]

RETURNS [type: CSEIndex] = {

IF t = Tree.Null THEN type ← P3S.implicitRecord

ELSE

WITH t SELECT FROM

subtree => {

node: Tree.Index = index;

temp: Tree.Link;

SELECT tb[node].name FROM

union => {

type ← WITH tb[node].son[1] SELECT FROM symbol => UnderType[index], ENDCASE => ERROR;

WITH seb[type] SELECT FROM

record =>

IF hints.variant AND tb[node].son[2] # Tree.Null

AND (temp←ListTail[tb[node].son[2]]) # Tree.Null THEN

type ← DiscriminatedType[type, temp];

ENDCASE => ERROR};

dollar => type ← UnderType[OperandType[tb[node].son[1]]];

dot => {

subType: CSEIndex = NormalType[OperandType[tb[node].son[1]]];

type ← WITH seb[subType] SELECT FROM ref => UnderType[refType], ENDCASE => ERROR};

assignx => type ← DiscriminatedType[baseType, tb[node].son[2]];

ENDCASE => type ← baseType};

ENDCASE => type ← baseType;

RETURN};

discrimination operations

Narrowing: PUBLIC PROC [type, target: Type] RETURNS [op: NarrowOp←[]] = {

typeL: CSEIndex ← UnderType[target];

typeR: CSEIndex ← UnderType[type];

nextL, nextR: Type;

IF ~Types.Equivalent[[dataPtr.ownSymbols, typeL], [dataPtr.ownSymbols, typeR]] THEN

WITH tR: seb[typeR] SELECT FROM

any => {

IF ~op.indirect THEN op.error ← TRUE;

WITH tL: seb[typeL] SELECT FROM

any => EXIT;

opaque => {

op.rtTest ← TRUE;

IF typeL # dataPtr.typeAtomRecord THEN op.unImpl ← TRUE;

EXIT};

ENDCASE => {

op.rtTest ← TRUE;

IF ~Discriminated[typeL] THEN EXIT;

nextL ← typeL; nextR ← TypeRoot[typeL]}};

record =>

WITH tL: seb[typeL] SELECT FROM

record => {

IF Types.Equivalent[[dataPtr.ownSymbols, typeL], [dataPtr.ownSymbols, typeR]]

THEN EXIT;

WITH vL: tL SELECT FROM

linked => {

uType: CSEIndex = VariantUnionType[vL.linkType];

WITH u: seb[uType] SELECT FROM

union => IF u.controlled THEN op.tagTest ← TRUE ELSE op.computed ← TRUE;

ENDCASE => op.error ← TRUE;

nextL ← vL.linkType; nextR ← typeR};

ENDCASE => op.error ← TRUE};

ENDCASE => op.error ← TRUE;

ref =>

WITH tL: seb[typeL] SELECT FROM

ref => {

IF op.indirect OR (tL.counted # tR.counted) OR (tR.readOnly AND ~tL.readOnly)

THEN op.error ← TRUE;

op.indirect ← TRUE;

nextL ← tL.refType; nextR ← tR.refType};

ENDCASE => op.error ← TRUE;

transfer =>

WITH tL: seb[typeL] SELECT FROM

transfer => {

IF op.indirect OR tL.mode # tR.mode OR tL.safe # tR.safe THEN

op.error ← TRUE;

SELECT tL.mode FROM

proc, signal, error => NULL;

ENDCASE => op.error ← TRUE;

IF TypeForm[tL.typeIn] = any OR TypeForm[tL.typeOut] = any THEN

op.error ← TRUE; -- for now

IF TypeForm[tR.typeIn] = any THEN

op.rtTest ← TRUE

ELSE IF ~Types.Equivalent[

[dataPtr.ownSymbols, tL.typeIn],

[dataPtr.ownSymbols, tR.typeIn]] THEN op.error ← TRUE;

IF TypeForm[tR.typeOut] = any THEN

op.rtTest ← TRUE

ELSE IF ~Types.Equivalent[

[dataPtr.ownSymbols, tL.typeOut],

[dataPtr.ownSymbols, tR.typeOut]] THEN op.error ← TRUE;

EXIT};

ENDCASE => op.error ← TRUE;

long =>

WITH tL: seb[typeL] SELECT FROM

long => {nextL ← tL.rangeType; nextR ← tR.rangeType};

ENDCASE => op.error ← TRUE;

ENDCASE => {

IF Types.Equivalent[[dataPtr.ownSymbols, typeL], [dataPtr.ownSymbols, typeR]]

THEN EXIT;

op.error ← TRUE};

IF op.error THEN EXIT;

typeL ← UnderType[nextL]; typeR ← UnderType[nextR];

ENDLOOP;

RETURN};

Discriminated: PROC [type: CSEIndex] RETURNS [BOOL] = INLINE {

RETURN [TypeLink[type] # nullType]}; -- check that at tag exists?

binding of variant records

Discrimination: PUBLIC PROC [node: Tree.Index, selection: Tree.Map] = {

OPEN tb[node];

copy: BOOL = (OpName[ListHead[son[3]]] = ditem);

type, subType: CSEIndex;

vCtx: CTXIndex;

base, discBase: Tree.Link;

attr: Attr;

entryNP: NPUse ← none;

unreachable: BOOL ← FALSE;

BindError: PROC = {

IF son[2] # Tree.Null THEN son[2] ← VoidExp[son[2]]; vCtx ← CTXNull};

PushCommonCtx: PROC = {

SELECT TRUE FROM

copy OR (seb[type].typeTag # record) => PushCtx[CTXNull];

(baseId = HTNull) => PushRecordCtx[LOOPHOLE[type], base, indirect];

ENDCASE => PushHtCtx[baseId, base, indirect]};

BindItem: Tree.Scan = {

subNode: Tree.Index = GetNode[t];

saveIndex: SourceMap.Loc = dataPtr.textIndex;

IF tb[subNode].name = ditem THEN {

declNode: Tree.Index = GetNode[tb[subNode].son[1]];

declType: CSEIndex;

Item: Tree.Map = {phraseNP ← entryNP; v ← selection[t]};

op: NarrowOp;

dataPtr.textIndex ← tb[declNode].info;

IF unreachable THEN {Log.Warning[unreachable]; unreachable ← FALSE};

Scope[subNode, Item];

declType ← UnderType[TypeForTree[tb[declNode].son[2]]];

op ← Narrowing[subType, declType];

SELECT TRUE FROM

~copy => Log.Error[discrimForm];

op.error => Log.ErrorSei[typeClash, FirstId[declNode]];

op.computed => Log.ErrorTree[missingBinding, base];

op.unImpl => Log.Warning[opaqueTest];

~(op.rtTest OR op.tagTest) => unreachable ← TRUE;

ENDCASE;

tb[subNode].attr1 ← op.indirect;

IF (tb[subNode].attr2 ← op.rtTest) THEN EnterType[MarkedType[declType]];

tb[subNode].attr3 ← op.tagTest}

ELSE {

vType: CSEIndex;

dataPtr.textIndex ← tb[subNode].info;

IF copy THEN {Log.Error[discrimForm]; attr3 ← FALSE};

[tb[subNode].son[1], vType] ← BindTest[tb[subNode].son[1], vCtx];

IF vType = typeANY THEN PushCommonCtx[]

ELSE {

WITH discBase SELECT FROM

subtree => tb[index].info ← vType;

ENDCASE => ERROR;

IF baseId = HTNull THEN PushRecordCtx[LOOPHOLE[vType], discBase, FALSE]

ELSE PushHtCtx[baseId, discBase, FALSE]};

phraseNP ← entryNP;

tb[subNode].son[2] ← selection[tb[subNode].son[2]];

PopCtx[];

tb[subNode].attr1 ← TRUE};

dataPtr.textIndex ← saveIndex};

saveImplicit: P3S.ImplicitInfo = P3S.implicit;

idNode: Tree.Index = GetNode[son[1]];

baseId: HTIndex = GetHash[tb[idNode].son[1]];

indirect: BOOL;

SealRefStack[];

base ← tb[idNode].son[2] ← Exp[tb[idNode].son[2], typeANY];

type ← UType[]; attr ← RAttr[]; RPop[];

UnsealRefStack[];

subType ← UnderType[CanonicalType[type]];

IF subType # type THEN tb[idNode].son[2] ← ForceType[tb[idNode].son[2], subType];

type ← NormalType[subType];

P3S.implicit ← [tree: base, type: subType, attr: attr];

IF (attr3 ← copy) THEN {

P3S.implicit.attr.noAssign ← P3S.implicit.attr.noXfer ← TRUE;

SELECT TypeForm[type] FROM

ref => {

attr2 ← (TypeForm[ReferentType[type]] = any);

indirect ← TRUE};

transfer => {attr2 ← TRUE; indirect ← FALSE};

ENDCASE => {attr2 ← FALSE; indirect ← FALSE};

IF baseId # HTNull THEN Log.Error[discrimForm]}

ELSE {

long: BOOL;

WITH t: seb[type] SELECT FROM

ref => {

indirect ← TRUE;

[base, type] ← OpenPointer[base, subType];

subType ← UnderType[OperandType[base]];

long ← seb[subType].typeTag = long};

ENDCASE => {indirect ← FALSE; long ← LongPath[base]};

IF P3S.safety = checked AND RCType[type] # none THEN

Log.ErrorTree[unsafeSelection, base];

WITH seb[type] SELECT FROM

record => {

tb[idNode].son[2] ← base ← BaseTree[base, subType];

IF hints.variant THEN {

uType: CSEIndex = VariantUnionType[type];

WITH u: seb[uType] SELECT FROM

union => {

tagType: Type = seb[u.tagSei].idType;

vCtx ← u.caseCtx;

IF son[2] = Tree.Null THEN {

IF ~u.controlled THEN Log.ErrorTree[missingBinding, base];

[] ← UpdateTreeAttr[base]; entryNP ← phraseNP;

PushTree[base]; PushSe[u.tagSei];

PushNode[IF indirect THEN dot ELSE dollar, 2];

SetInfo[tagType]; SetAttr[2, long]; son[2] ← PopTree[]}

ELSE {

IF u.controlled THEN Log.ErrorTree[spuriousBinding, son[2]];

PushCommonCtx[];

son[2] ← Rhs[son[2], TargetType[tagType]];

entryNP ← phraseNP; RPop[];

PopCtx[]}};

ENDCASE => {Log.Error[noAccess]; BindError[]}}

ELSE {Log.ErrorTree[noVariants, tb[idNode].son[2]]; BindError[]};

PushTree[base];

IF indirect THEN {PushNode[uparrow, 1]; SetAttr[2, long]}

ELSE PushNode[cast, 1];

discBase ← PopTree[]};

ENDCASE => {

Log.ErrorTree[noVariants, tb[idNode].son[2]]; BindError[];

discBase ← Tree.Null}};

attr1 ← indirect;

ScanList[son[3], BindItem];

PushCommonCtx[]; phraseNP ← entryNP; son[4] ← selection[son[4]]; PopCtx[];

RPush[CSENull, attr];

P3S.implicit ← saveImplicit};

BindTest: PROC [t: Tree.Link, vCtx: CTXIndex]

RETURNS [val: Tree.Link, vType: CSEIndex] = {

mixed: BOOL ← FALSE;

TestItem: Tree.Map = {

WITH t SELECT FROM

subtree => {

subNode: Tree.Index = index;

SELECT tb[subNode].name FROM

relE =>

WITH tb[subNode].son[2] SELECT FROM

hash => {

iType: ISEIndex;

uType: CSEIndex;

found: BOOL;

[found, iType] ← SearchCtxList[index, vCtx];

IF found THEN {

uType ← UnderType[iType];

tb[subNode].son[2] ← [symbol[index: iType]];

SELECT vType FROM

uType => NULL;

typeANY => vType ← uType;

ENDCASE => mixed ← TRUE}

ELSE IF vCtx # CTXNull THEN Log.ErrorHti[unknownVariant, index];

tb[subNode].info ← dataPtr.idBOOL;

tb[subNode].attr1 ← tb[subNode].attr2 ← FALSE;

v ← t};

ENDCASE => {

v ← Rhs[t, dataPtr.idBOOL]; RPop[];

Log.ErrorTree[nonVariantLabel, t]};

ENDCASE => {

v ← Rhs[t, dataPtr.idBOOL]; RPop[];

Log.ErrorTree[nonVariantLabel, t]}};

ENDCASE => ERROR;

RETURN};

vType ← typeANY; val ← UpdateList[t, TestItem];

IF mixed THEN vType ← typeANY;

RETURN};