-- file Pass3Xb.Mesa -- last modified by Satterthwaite, December 17, 1979 1:45 PM DIRECTORY ComData: FROM "comdata" USING [ definitionsOnly, idCARDINAL, nTypeCodes, ownSymbols, typeMap, typeMapId, typeBOOLEAN, typeCHARACTER, typeINTEGER, typeSTRING], InlineDefs: FROM "inlinedefs" USING [BITAND], Log: FROM "log" USING [Error, ErrorN, ErrorNode, ErrorSei, ErrorTree], P3: FROM "p3" USING [ Attr, EmptyAttr, FullAttr, VoidAttr, NPUse, BoundNP, MergeNP, SequenceNP, phraseNP, Addr, All, --And,-- Apply, Assignment, Bundling, CanonicalType, Case, ClearRefStack, DescOp, Discrimination, Dot, Id, IdentifiedType, MakeLongType, MiscXfer, OperandInline, OrderedType, PopCtx, PushCtx, RecordMention, SealRefStack, TargetType, TypeExp, TypeForTree, Unbundle, UnsealRefStack, UpArrow], Pass3: FROM "pass3" USING [implicitAttr, implicitRecord, implicitTree, implicitType], Symbols: FROM "symbols" USING [ctxType, seType, SEIndex, ISEIndex, CSEIndex, RecordSEIndex, CSENull, RecordSENull, codeCHARACTER, codeINTEGER, typeANY], SymbolOps: FROM "symbolops" USING [ConstantId, NormalType, TypeForm, UnderType], Table: FROM "table" USING [Base, Notifier], Tree: FROM "tree" USING [Index, Link, Map, Null, treeType], TreeOps: FROM "treeops" USING [ GetNode, ListLength, PopTree, PushTree, PushNode, SetInfo, TestTree, UpdateList], Types: FROM "types" USING [SymbolTableBase, Assignable, Equivalent]; Pass3Xb: PROGRAM IMPORTS InlineDefs, Log, P3, SymbolOps, TreeOps, Types, dataPtr: ComData, passPtr: Pass3 EXPORTS P3 = BEGIN OPEN SymbolOps, TreeOps, P3; And: PROCEDURE [Attr, Attr] RETURNS [Attr] = LOOPHOLE[InlineDefs.BITAND]; -- pervasive definitions from SymDefs SEIndex: TYPE = Symbols.SEIndex; ISEIndex: TYPE = Symbols.ISEIndex; CSEIndex: TYPE = Symbols.CSEIndex; RecordSEIndex: TYPE = Symbols.RecordSEIndex; typeANY: Symbols.CSEIndex = Symbols.typeANY; tb: Table.Base; -- tree base address (local copy) seb: Table.Base; -- se table base address (local copy) ctxb: Table.Base; -- context table base address (local copy) own: Types.SymbolTableBase; ExpBNotify: PUBLIC Table.Notifier = BEGIN -- called by allocator whenever table area is repacked seb _ base[Symbols.seType]; ctxb _ base[Symbols.ctxType]; tb _ base[Tree.treeType]; RETURN END; -- intermediate result bookkeeping OperandDescriptor: TYPE = RECORD[ type: CSEIndex, -- type of operand attr: Attr]; -- attributes RStackLimit: INTEGER = 32; rStack: ARRAY [0 .. RStackLimit] OF OperandDescriptor; rI: INTEGER; -- index into rStack OperandStackOverflow: SIGNAL = CODE; RPush: PUBLIC PROCEDURE [type: CSEIndex, attr: Attr] = BEGIN IF rI >= RStackLimit THEN ERROR OperandStackOverflow; rI _ rI + 1; rStack[rI] _ OperandDescriptor[type:type, attr:attr]; END; RPop: PUBLIC PROCEDURE = BEGIN IF rI < 0 THEN ERROR; rI _ rI-1; END; RType: PUBLIC PROCEDURE RETURNS [CSEIndex] = BEGIN RETURN [rStack[rI].type] END; RAttr: PUBLIC PROCEDURE RETURNS [Attr] = BEGIN RETURN [rStack[rI].attr] END; longUnsigned: CSEIndex; -- a hint for mwconst ExpInit: PUBLIC PROCEDURE = BEGIN passPtr.implicitType _ typeANY; passPtr.implicitTree _ Tree.Null; passPtr.implicitRecord _ Symbols.RecordSENull; own _ dataPtr.ownSymbols; -- make a parameter? longUnsigned _ Symbols.CSENull; rI _ -1; END; -- tree manipulation utilities OperandType: PUBLIC PROCEDURE [t: Tree.Link] RETURNS [CSEIndex] = BEGIN RETURN [WITH e:t SELECT FROM symbol => UnderType[seb[e.index].idType], literal => WITH e.info SELECT FROM string => dataPtr.typeSTRING, ENDCASE => dataPtr.typeINTEGER, subtree => tb[e.index].info, ENDCASE => Symbols.CSENull] END; -- type manipulation UnresolvedTypes: SIGNAL RETURNS [CSEIndex] = CODE; BalanceTypes: PROCEDURE [type1, type2: CSEIndex] RETURNS [type: CSEIndex] = BEGIN n1, n2: CARDINAL; SELECT TRUE FROM (type1 = type2), (type2 = typeANY) => type _ type1; (type1 = typeANY) => type _ type2; ENDCASE => BEGIN n1 _ Bundling[type1]; n2 _ Bundling[type2]; WHILE n1 > n2 DO type1 _ Unbundle[LOOPHOLE[type1]]; n1 _ n1-1 ENDLOOP; WHILE n2 > n1 DO type2 _ Unbundle[LOOPHOLE[type2]]; n2 _ n2-1 ENDLOOP; -- check bundling DO type1 _ TargetType[type1]; type2 _ TargetType[type2]; SELECT TRUE FROM Types.Assignable[[own, type1], [own, type2]] => BEGIN type _ type1; EXIT END; Types.Assignable[[own, type2], [own, type1]] => BEGIN type _ type2; EXIT END; ENDCASE; IF n1 = 0 THEN GO TO Fail; n1 _ n1-1; type1 _ Unbundle[LOOPHOLE[type1]]; type2 _ Unbundle[LOOPHOLE[type2]]; REPEAT Fail => type _ SIGNAL UnresolvedTypes; ENDLOOP; END; RETURN END; ForceType: PUBLIC PROCEDURE [t: Tree.Link, type: CSEIndex] RETURNS [Tree.Link] = BEGIN PushTree[t]; WITH t SELECT FROM subtree => SELECT tb[index].name FROM construct, union, rowcons => PushNode[cast, 1]; openx => PushNode[cast, 1]; ENDCASE; ENDCASE => PushNode[cast, 1]; SetInfo[type]; RETURN [PopTree[]] END; -- expressions Exp: PUBLIC PROCEDURE [exp: Tree.Link, target: CSEIndex] RETURNS [val: Tree.Link] = BEGIN type: CSEIndex; attr: Attr; phraseNP _ none; IF exp = Tree.Null THEN BEGIN RPush[passPtr.implicitType, passPtr.implicitAttr]; RETURN [Tree.Null] END; WITH e:exp SELECT FROM symbol => BEGIN sei: ISEIndex = e.index; attr.noXfer _ attr.noAssign _ TRUE; RecordMention[sei]; type _ UnderType[seb[sei].idType]; SELECT ctxb[seb[sei].idCtx].ctxType FROM included => IF ~(attr.const_ConstantId[sei]) THEN Log.ErrorSei[unimplemented, sei]; imported => attr.const _ ConstantId[sei]; ENDCASE => attr.const _ seb[sei].constant; RPush[type, attr]; val _ exp; END; hash => WITH seb[target] SELECT FROM enumerated => BEGIN PushCtx[valueCtx]; val _ Id[e.index]; PopCtx[] END; ENDCASE => val _ Id[e.index]; literal => BEGIN attr.noXfer _ attr.noAssign _ TRUE; WITH e.info SELECT FROM string => BEGIN type _ dataPtr.typeSTRING; attr.const _ FALSE; IF dataPtr.definitionsOnly THEN Log.ErrorTree[unimplemented, exp]; END; ENDCASE => BEGIN type _ dataPtr.typeINTEGER; attr.const _TRUE END; RPush[type, attr]; val _ exp; END; subtree => BEGIN node: Tree.Index _ e.index; val _ exp; -- the default SELECT tb[node].name FROM dot => Dot[node]; uparrow => UpArrow[node]; apply => BEGIN Apply[node, target, FALSE]; CheckNonVoid[node, target] END; uminus, abs => UnaryOp[node]; plus => Plus[node]; minus => Minus[node]; times, div, mod => ArithOp[node]; relE, relN => RelOp[node, FALSE]; relL, relGE, relG, relLE => RelOp[node, TRUE]; in, notin => In[node]; not => tb[node].son[1] _ Rhs[tb[node].son[1], dataPtr.typeBOOLEAN]; or, and => BoolOp[node]; ifx => IfExp[node, target]; casex => SelectExp[node, target, Case]; bindx => SelectExp[node, target, Discrimination]; assignx => Assignment[node]; min, max => MinMax[node, target]; addr => Addr[node, target]; base, length, arraydesc => DescOp[node, target]; all => All[node, target]; mwconst => BEGIN IF longUnsigned = Symbols.CSENull THEN longUnsigned _ MakeLongType[dataPtr.idCARDINAL, typeANY]; RPush[longUnsigned, FullAttr]; END; void => RPush[target, VoidAttr]; clit => RPush[dataPtr.typeCHARACTER, FullAttr]; llit => BEGIN attr _ FullAttr; attr.const _ FALSE; RPush[dataPtr.typeSTRING, attr]; END; signalx, errorx, fork, joinx, new, startx => BEGIN val _ MiscXfer[node, target]; node _ GetNode[val]; CheckNonVoid[node, target]; END; syserrorx => BEGIN RPush[Symbols.CSENull, EmptyAttr]; CheckNonVoid[node, target]; END; lengthen => BEGIN OPEN tb[node]; type: CSEIndex; son[1] _ GenericRhs[son[1], target]; type _ rStack[rI].type; IF type = dataPtr.typeINTEGER OR seb[type].typeTag = pointer OR seb[type].typeTag = arraydesc THEN rStack[rI].type _ MakeLongType[type, target] ELSE BEGIN Log.ErrorTree[typeClash, son[1]]; rStack[rI].type _ typeANY; END; END; safen => tb[node].son[1] _ Exp[tb[node].son[1], target]; loophole => BEGIN OPEN tb[node]; son[1] _ Exp[son[1], typeANY]; IF son[2] = Tree.Null THEN BEGIN IF target = typeANY THEN Log.ErrorNode[noTarget, node]; rStack[rI].type _ target; END ELSE BEGIN son[2] _ TypeExp[son[2]]; rStack[rI].type _ UnderType[TypeForTree[son[2]]]; END; END; size => BEGIN OPEN tb[node]; son[1] _ TypeExp[son[1]]; RPush[dataPtr.typeINTEGER, FullAttr]; END; first, last => EndPoint[node]; typecode => BEGIN OPEN tb[node]; IF dataPtr.definitionsOnly THEN Log.Error[unimplemented]; son[1] _ TypeExp[son[1]]; EnterTypeCode[TypeForTree[son[1]]]; RPush[typeANY, FullAttr]; END; item => tb[node].son[2] _ Exp[tb[node].son[2], target]; ENDCASE => BEGIN Log.Error[unimplemented]; RPush[typeANY, EmptyAttr] END; tb[node].info _ rStack[rI].type; END; ENDCASE; RETURN END; CheckNonVoid: PROCEDURE [node: Tree.Index, target: CSEIndex] = BEGIN IF rStack[rI].type = Symbols.CSENull THEN SELECT tb[node].name FROM error => BEGIN tb[node].name _ errorx; rStack[rI].type _ target END; errorx, syserrorx => rStack[rI].type _ target; ENDCASE => BEGIN Log.ErrorNode[typeClash, node]; rStack[rI].type _ typeANY; END; END; VoidExp: PUBLIC PROCEDURE [exp: Tree.Link] RETURNS [val: Tree.Link] = BEGIN val _ Exp[exp, typeANY]; RPop[]; RETURN END; UniOperand: PROCEDURE [node: Tree.Index] RETURNS [valid: BOOLEAN] = BEGIN l: CARDINAL = ListLength[tb[node].son[1]]; IF ~(valid _ l=1) THEN BEGIN IF l > 1 THEN Log.ErrorN[listLong, l-1] ELSE Log.ErrorN[listShort, l+1]; tb[node].son[1] _ UpdateList[tb[node].son[1], VoidExp]; RPush[typeANY, EmptyAttr]; END; RETURN END; -- arithmetic expression manipulation NumericAny: PROCEDURE [type: CSEIndex] RETURNS [CSEIndex] = BEGIN RETURN [SELECT seb[type].typeTag FROM long => MakeLongType[dataPtr.typeINTEGER, type], ENDCASE => dataPtr.typeINTEGER] END; EvalNumeric: PROCEDURE [t: Tree.Link] RETURNS [val: Tree.Link] = BEGIN val _ GenericRhs[t, dataPtr.typeINTEGER]; SELECT NormalType[rStack[rI].type] FROM dataPtr.typeINTEGER => NULL; typeANY => rStack[rI].type _ NumericAny[rStack[rI].type]; ENDCASE => Log.ErrorTree[typeClash, val]; RETURN END; ArithOp: PROCEDURE [node: Tree.Index] = BEGIN OPEN tb[node]; saveNP: NPUse; son[1] _ EvalNumeric[son[1]]; saveNP _ phraseNP; son[2] _ EvalNumeric[son[2]]; BalanceAttributes[node]; rStack[rI-1].attr _ And[rStack[rI-1].attr, rStack[rI].attr]; IF attr1 THEN rStack[rI-1].attr.const _ FALSE; RPop[]; phraseNP _ MergeNP[saveNP][phraseNP]; END; ArithType: PROCEDURE [type: CSEIndex] RETURNS [CSEIndex] = BEGIN type _ NormalType[type]; RETURN [WITH seb[type] SELECT FROM relative => NormalType[UnderType[offsetType]], ENDCASE => type] END; Plus: PROCEDURE [node: Tree.Index] = BEGIN OPEN tb[node]; type: CSEIndex; lr: BOOLEAN; saveNP: NPUse; son[1] _ GenericRhs[son[1], typeANY]; saveNP _ phraseNP; type _ ArithType[rStack[rI].type]; IF seb[type].typeTag = pointer OR type = dataPtr.typeCHARACTER THEN BEGIN lr _ TRUE; son[2] _ EvalNumeric[son[2]] END ELSE BEGIN SELECT type FROM dataPtr.typeINTEGER, typeANY => NULL; ENDCASE => Log.ErrorTree[typeClash, son[1]]; son[2] _ GenericRhs[son[2], typeANY]; lr _ FALSE; type _ ArithType[rStack[rI].type]; SELECT TRUE FROM type = dataPtr.typeINTEGER, type = dataPtr.typeCHARACTER => NULL; seb[type].typeTag = pointer => NULL; ENDCASE => BEGIN IF type # typeANY THEN Log.ErrorTree[typeClash, son[2]]; rStack[rI].type _ NumericAny[rStack[rI].type]; END; END; BalanceAttributes[node]; rStack[rI-1].attr _ And[rStack[rI-1].attr, rStack[rI].attr]; IF attr1 THEN rStack[rI-1].attr.const _ FALSE; IF ~lr THEN rStack[rI-1].type _ rStack[rI].type; RPop[]; phraseNP _ MergeNP[saveNP][phraseNP]; END; Minus: PROCEDURE [node: Tree.Index] = BEGIN OPEN tb[node]; type, subType: CSEIndex; lr: BOOLEAN; saveNP: NPUse; son[1] _ GenericRhs[son[1], typeANY]; saveNP _ phraseNP; type _ NormalType[rStack[rI].type]; subType _ ArithType[type]; lr _ TRUE; IF seb[subType].typeTag = pointer OR subType = dataPtr.typeCHARACTER THEN BEGIN son[2] _ GenericRhs[son[2], typeANY]; subType _ NormalType[rStack[rI].type]; SELECT TRUE FROM subType = typeANY => NULL; Types.Equivalent[[own, type], [own, subType]] => lr _ FALSE; subType = dataPtr.typeINTEGER => NULL; ENDCASE => Log.ErrorTree[typeClash, son[2]]; END ELSE BEGIN SELECT type FROM dataPtr.typeINTEGER, typeANY => NULL; ENDCASE => BEGIN Log.ErrorTree[typeClash, son[1]]; rStack[rI].type _ typeANY; END; son[2] _ EvalNumeric[son[2]]; END; BalanceAttributes[node]; rStack[rI-1].attr _ And[rStack[rI-1].attr, rStack[rI].attr]; IF attr1 THEN rStack[rI-1].attr.const _ FALSE; IF ~lr THEN rStack[rI-1].type _ IF attr2 THEN MakeLongType[dataPtr.typeINTEGER, rStack[rI].type] ELSE dataPtr.typeINTEGER; RPop[]; phraseNP _ MergeNP[saveNP][phraseNP]; END; UnaryOp: PROCEDURE [node: Tree.Index] = BEGIN IF UniOperand[node] THEN BEGIN OPEN tb[node]; son[1] _ EvalNumeric[son[1]]; SetAttributes[node]; IF attr1 THEN rStack[rI].attr.const _ FALSE; END; END; RelOp: PROCEDURE [node: Tree.Index, ordered: BOOLEAN] = BEGIN OPEN tb[node]; type: CSEIndex; attr: Attr; saveNP: NPUse; implicitOp: BOOLEAN; son[1] _ GenericRhs[son[1], typeANY]; saveNP _ phraseNP; type _ NormalType[rStack[rI].type]; implicitOp _ (son[1] = Tree.Null); son[2] _ GenericRhs[son[2], type]; type _ BalanceTypes[type, NormalType[rStack[rI].type] !UnresolvedTypes => BEGIN Log.ErrorTree[typeClash, son[2]]; RESUME [typeANY] END]; IF (ordered AND ~OrderedType[type]) OR (~ordered AND ~IdentifiedType[type]) THEN Log.ErrorNode[relationType, node]; BalanceAttributes[node]; attr _ And[rStack[rI-1].attr, rStack[rI].attr]; IF implicitOp AND son[1] # Tree.Null THEN Log.ErrorTree[typeClash, son[2]]; SELECT seb[type].typeTag FROM basic, enumerated => NULL; transfer => BEGIN IF OperandInline[son[1]] THEN Log.ErrorTree[misusedInline, son[1]]; IF OperandInline[son[2]] THEN Log.ErrorTree[misusedInline, son[2]]; attr.const _ FALSE; END; real => attr.const _ FALSE; ENDCASE; RPop[]; RPop[]; RPush[dataPtr.typeBOOLEAN, attr]; phraseNP _ MergeNP[saveNP][phraseNP]; END; In: PROCEDURE [node: Tree.Index] = BEGIN OPEN tb[node]; saveNP: NPUse; son[1] _ GenericRhs[son[1], typeANY]; saveNP _ phraseNP; son[2] _ Range[son[2], rStack[rI].type]; SetAttributes[node]; rStack[rI-1].attr _ And[rStack[rI-1].attr, rStack[rI].attr]; RPop[]; rStack[rI].type _ dataPtr.typeBOOLEAN; phraseNP _ MergeNP[saveNP][phraseNP]; END; BoolOp: PROCEDURE [node: Tree.Index] = BEGIN OPEN tb[node]; attr: Attr; saveNP: NPUse; SealRefStack[]; son[1] _ Rhs[son[1], dataPtr.typeBOOLEAN]; saveNP _ phraseNP; ClearRefStack[]; son[2] _ Rhs[son[2], dataPtr.typeBOOLEAN]; UnsealRefStack[]; attr _ And[rStack[rI-1].attr, rStack[rI].attr]; RPop[]; RPop[]; RPush[dataPtr.typeBOOLEAN, attr]; phraseNP _ SequenceNP[saveNP][phraseNP]; END; Interval: PUBLIC PROCEDURE [t: Tree.Link, type: CSEIndex, constant: BOOLEAN] = BEGIN node: Tree.Index = GetNode[t]; saveNP: NPUse; type _ TargetType[type]; tb[node].son[1] _ Rhs[tb[node].son[1], type]; saveNP _ phraseNP; IF constant AND ~rStack[rI].attr.const THEN Log.ErrorTree[nonConstant, tb[node].son[1]]; tb[node].son[2] _ Rhs[tb[node].son[2], type]; IF constant AND ~rStack[rI].attr.const THEN Log.ErrorTree[nonConstant, tb[node].son[2]]; SetAttributes[node]; rStack[rI-1].attr _ And[rStack[rI-1].attr, rStack[rI].attr]; RPop[]; IF seb[type].typeTag = real THEN rStack[rI].attr.const _ FALSE; phraseNP _ MergeNP[saveNP][phraseNP]; END; Range: PUBLIC PROCEDURE [t: Tree.Link, type: CSEIndex] RETURNS [val: Tree.Link] = BEGIN subType: CSEIndex; node: Tree.Index; WITH t SELECT FROM subtree => BEGIN node _ index; SELECT tb[node].name FROM subrangeTC => BEGIN val _ t; tb[node].son[1] _ TypeExp[tb[node].son[1]]; subType _ TargetType[UnderType[TypeForTree[tb[node].son[1]]]]; Interval[tb[node].son[2], subType, FALSE]; END; IN [intOO .. intCC] => BEGIN val _ t; subType _ IF type # typeANY THEN type ELSE dataPtr.typeINTEGER; Interval[t, subType, FALSE]; END; ENDCASE => BEGIN val _ TypeExp[t]; subType _ TargetType[UnderType[TypeForTree[val]]]; RPush[subType, FullAttr]; phraseNP _ none; END; END; ENDCASE => BEGIN val _ TypeExp[t]; subType _ TargetType[UnderType[TypeForTree[val]]]; RPush[subType, FullAttr]; phraseNP _ none; END; IF ~OrderedType[subType] AND subType # typeANY THEN Log.Error[nonOrderedType]; IF ~Types.Assignable[ [dataPtr.ownSymbols, type], [dataPtr.ownSymbols, subType]] THEN Log.ErrorTree[typeClash, val]; RETURN END; BalancedTarget: PROCEDURE [target, type: CSEIndex] RETURNS [CSEIndex] = BEGIN RETURN [IF target = typeANY OR (~Types.Equivalent[[own, type], [own, target]] AND NormalType[type] = target) THEN TargetType[type] ELSE target] END; ResolveTypes: PROCEDURE [type1, type2, target: CSEIndex, t: Tree.Link] RETURNS [type: CSEIndex] = BEGIN failed: BOOLEAN; IF target = typeANY THEN failed _ TRUE ELSE BEGIN ENABLE UnresolvedTypes => BEGIN failed _ TRUE; RESUME [typeANY] END; failed _ FALSE; type1 _ BalanceTypes[target, type1]; type2 _ BalanceTypes[target, type2]; type _ BalanceTypes[type1, type2]; END; IF failed THEN BEGIN Log.ErrorTree[typeClash, t]; type _ typeANY END; RETURN END; IfExp: PROCEDURE [node: Tree.Index, target: CSEIndex] = BEGIN OPEN tb[node]; type: CSEIndex; attr: Attr; entryNP, saveNP: NPUse; SealRefStack[]; son[1] _ Rhs[son[1], dataPtr.typeBOOLEAN]; attr _ rStack[rI].attr; RPop[]; entryNP _ phraseNP; UnsealRefStack[]; son[2] _ BalancedRhs[son[2], target]; attr _ And[attr, rStack[rI].attr]; saveNP _ SequenceNP[entryNP][phraseNP]; type _ rStack[rI].type; RPop[]; target _ BalancedTarget[target, type]; son[3] _ BalancedRhs[son[3], target]; attr _ And[attr, rStack[rI].attr]; type _ BalanceTypes[type, rStack[rI].type !UnresolvedTypes => RESUME [ResolveTypes[type, rStack[rI].type, target, son[3]]]]; phraseNP _ BoundNP[saveNP][SequenceNP[entryNP][phraseNP]]; RPop[]; RPush[type, attr]; END; SelectExp: PROCEDURE [node: Tree.Index, target: CSEIndex, driver: PROCEDURE [Tree.Index, Tree.Map]] = BEGIN type: CSEIndex; attr: Attr; saveNP: NPUse; started: BOOLEAN; Selection: Tree.Map = BEGIN subType: CSEIndex; entryNP: NPUse = phraseNP; v _ BalancedRhs[t, target]; subType _ BalanceTypes[type, rStack[rI].type !UnresolvedTypes => RESUME [ResolveTypes[type, rStack[rI].type, target, v]]]; saveNP _ BoundNP[saveNP][SequenceNP[entryNP][phraseNP]]; IF subType # typeANY THEN type _ subType; IF ~started THEN target _ BalancedTarget[target, type]; attr _ And[attr, rStack[rI].attr]; RPop[]; started _ TRUE; RETURN END; type _ typeANY; attr _ FullAttr; started _ FALSE; saveNP _ none; driver[node, Selection]; attr _ And[attr, rStack[rI].attr]; RPop[]; attr.const _ FALSE; RPush[type, attr]; phraseNP _ saveNP; END; MinMax: PROCEDURE [node: Tree.Index, target: CSEIndex] = BEGIN OPEN tb[node]; attr: Attr; saveNP: NPUse; started: BOOLEAN; type: CSEIndex; SubMinMax: Tree.Map = BEGIN subType: CSEIndex; v _ BalancedRhs[t, target]; attr _ And[attr, rStack[rI].attr]; saveNP _ MergeNP[saveNP][phraseNP]; subType _ CanonicalType[rStack[rI].type]; subType _ BalanceTypes[subType, type !UnresolvedTypes => RESUME[ResolveTypes[subType, type, target, v]]]; IF type # subType AND subType # typeANY THEN BEGIN IF ~OrderedType[subType] THEN Log.ErrorNode[relationType, node]; type _ subType; IF ~started THEN target _ BalancedTarget[target, type]; END; RPop[]; started _ TRUE; RETURN END; attr _ FullAttr; saveNP _ none; started _ FALSE; type _ typeANY; son[1] _ UpdateList[son[1], SubMinMax]; SELECT seb[type].typeTag FROM long => BEGIN attr1 _ FALSE; attr2 _ TRUE END; real => BEGIN attr1 _ TRUE; attr2 _ FALSE; attr.const _ FALSE END; ENDCASE => attr1 _ attr2 _ FALSE; RPush[type, attr]; phraseNP _ saveNP; END; EndPoint: PROCEDURE [node: Tree.Index] = BEGIN OPEN tb[node]; type: CSEIndex; son[1] _ TypeExp[son[1]]; type _ UnderType[TypeForTree[son[1]]]; BEGIN WITH seb[type] SELECT FROM basic => SELECT code FROM Symbols.codeINTEGER, Symbols.codeCHARACTER => NULL; ENDCASE => GO TO fail; enumerated => NULL; relative => IF TypeForm[offsetType] # subrange THEN GO TO fail; subrange => NULL; long => IF NormalType[UnderType[rangeType]] # dataPtr.typeINTEGER THEN GO TO fail; ENDCASE => GO TO fail; EXITS fail => Log.ErrorTree[typeClash, son[1]]; END; RPush[type, FullAttr]; END; EnterTypeCode: PROCEDURE [code: SEIndex] = BEGIN i: CARDINAL; FOR i IN [0 .. dataPtr.nTypeCodes) DO IF code = dataPtr.typeMap[i] THEN EXIT; REPEAT FINISHED => BEGIN dataPtr.typeMap[dataPtr.nTypeCodes] _ code; dataPtr.nTypeCodes _ dataPtr.nTypeCodes + 1; END; ENDLOOP; RecordMention[dataPtr.typeMapId]; END; Rhs: PUBLIC PROCEDURE [exp: Tree.Link, lhsType: CSEIndex] RETURNS [val: Tree.Link] = BEGIN rhsType: CSEIndex; val _ Exp[exp, lhsType]; rhsType _ rStack[rI].type; SELECT TRUE FROM (lhsType = rhsType), (lhsType = typeANY) => NULL; (rhsType = typeANY) => BEGIN SELECT seb[lhsType].typeTag FROM long, real => val _ Lengthen[val, MakeLongType[typeANY, lhsType]]; ENDCASE; rStack[rI].type _ lhsType; END; ENDCASE => BEGIN -- immediate matching is inconclusive UNTIL Types.Assignable[[own, lhsType], [own, rhsType]] DO WITH seb[rhsType] SELECT FROM subrange => rhsType _ UnderType[rangeType]; record => BEGIN IF Bundling[rhsType] = 0 THEN GO TO nomatch; rhsType _ Unbundle[LOOPHOLE[rhsType, RecordSEIndex]]; val _ ForceType[val, rhsType]; END; ENDCASE => BEGIN SELECT seb[lhsType].typeTag FROM long => BEGIN IF ~Types.Assignable[ [own, NormalType[lhsType]], [own, rhsType]] THEN GO TO nomatch; IF seb[rhsType].typeTag # real THEN val _ Lengthen[val, lhsType]; END; real => SELECT NormalType[rhsType] FROM dataPtr.typeINTEGER, typeANY => BEGIN val _ Float[val, rhsType, lhsType]; rStack[rI].attr.const _ FALSE; END; ENDCASE => GO TO nomatch; ENDCASE => GO TO nomatch; rhsType _ lhsType; END REPEAT nomatch => BEGIN -- no coercion is possible Log.ErrorTree[typeClash, IF exp = Tree.Null THEN passPtr.implicitTree ELSE val]; rhsType _ lhsType; END; ENDLOOP; rStack[rI].type _ IF rhsType = typeANY THEN lhsType ELSE rhsType; END; IF seb[rhsType].typeTag = transfer AND OperandInline[val] THEN Log.ErrorTree[misusedInline, val]; RETURN END; GenericRhs: PROCEDURE [exp: Tree.Link, target: CSEIndex] RETURNS [val: Tree.Link] = BEGIN type: CSEIndex; val _ Exp[exp, target]; type _ rStack[rI].type; -- put value in canonical form DO WITH seb[type] SELECT FROM subrange => type _ UnderType[rangeType]; record => BEGIN IF Bundling[type] = 0 THEN EXIT; type _ Unbundle[LOOPHOLE[type, RecordSEIndex]]; val _ ForceType[val, type]; END; ENDCASE => EXIT; rStack[rI].type _ type; ENDLOOP; RETURN END; BalancedRhs: PROCEDURE [exp: Tree.Link, target: CSEIndex] RETURNS [val: Tree.Link] = BEGIN type: CSEIndex; val _ Exp[exp, target]; SELECT seb[target].typeTag FROM long, real => BEGIN type _ CanonicalType[rStack[rI].type]; IF type # typeANY AND seb[target].typeTag # seb[type].typeTag AND Types.Equivalent[ [own, NormalType[target]], [own, type]] THEN BEGIN SELECT seb[target].typeTag FROM long => IF seb[type].typeTag # real THEN val _ Lengthen[val, target]; real => BEGIN val _ Float[val, type, target]; rStack[rI].attr.const _ FALSE; END; ENDCASE; rStack[rI].type _ target; END; END; ENDCASE; RETURN END; SetAttributes: PROCEDURE [node: Tree.Index] = BEGIN SELECT seb[rStack[rI].type].typeTag FROM long => BEGIN tb[node].attr1 _ FALSE; tb[node].attr2 _ TRUE END; real => BEGIN tb[node].attr1 _ TRUE; tb[node].attr2 _ FALSE END; ENDCASE => tb[node].attr1 _ tb[node].attr2 _ FALSE; END; BalanceAttributes: PROCEDURE [node: Tree.Index] = BEGIN lType, rType: CSEIndex; lType _ rStack[rI-1].type; rType _ rStack[rI].type; SELECT seb[lType].typeTag FROM long => BEGIN SELECT seb[rType].typeTag FROM long => BEGIN tb[node].attr1 _ FALSE; tb[node].attr2 _ TRUE END; real => BEGIN rStack[rI-1].type _ rType; tb[node].son[1] _ Float[tb[node].son[1], lType, rType]; rStack[rI-1].attr.const _ FALSE; tb[node].attr1 _ TRUE; tb[node].attr2 _ FALSE; END; ENDCASE => BEGIN rStack[rI].type _ rType _ MakeLongType[rType, lType]; tb[node].son[2] _ Lengthen[tb[node].son[2], rType]; tb[node].attr1 _ FALSE; tb[node].attr2 _ TRUE; END; END; real => BEGIN tb[node].attr1 _ TRUE; tb[node].attr2 _ FALSE; SELECT seb[rType].typeTag FROM real => NULL; ENDCASE => BEGIN rStack[rI].type _ lType; tb[node].son[2] _ Float[tb[node].son[2], rType, lType]; rStack[rI].attr.const _ FALSE; END; END; ENDCASE => SELECT seb[rType].typeTag FROM long => BEGIN rStack[rI-1].type _ lType _ MakeLongType[lType, rType]; tb[node].son[1] _ Lengthen[tb[node].son[1], lType]; tb[node].attr1 _ FALSE; tb[node].attr2 _ TRUE; END; real => BEGIN rStack[rI-1].type _ rType; tb[node].son[1] _ Float[tb[node].son[1], lType, rType]; rStack[rI-1].attr.const _ FALSE; tb[node].attr1 _ TRUE; tb[node].attr2 _ FALSE; END; ENDCASE => tb[node].attr1 _ tb[node].attr2 _ FALSE; END; Lengthen: PROCEDURE [t: Tree.Link, target: CSEIndex] RETURNS [v: Tree.Link] = BEGIN IF TestTree[t, arraydesc] THEN v _ LengthenDesc[t, target] ELSE BEGIN PushTree[t]; PushNode[lengthen, 1]; SetInfo[target]; v _ PopTree[]; END; RETURN END; LengthenDesc: PROCEDURE [t: Tree.Link, target: CSEIndex] RETURNS [Tree.Link] = BEGIN node: Tree.Index = GetNode[t]; subNode: Tree.Index = GetNode[tb[node].son[1]]; tb[subNode].son[1] _ Lengthen[tb[subNode].son[1], MakeLongType[OperandType[tb[subNode].son[1]], typeANY]]; tb[node].info _ MakeLongType[tb[node].info, target]; tb[node].attr2 _ TRUE; RETURN [t] END; Float: PROCEDURE [t: Tree.Link, type, target: CSEIndex] RETURNS [Tree.Link] = BEGIN PushTree[IF seb[type].typeTag = long THEN t ELSE Lengthen[t, MakeLongType[type, typeANY]]]; SELECT NormalType[type] FROM dataPtr.typeINTEGER => BEGIN PushNode[float, 1]; SetInfo[target] END; typeANY => NULL; ENDCASE => Log.ErrorTree[typeClash, t]; RETURN [PopTree[]] END; END.