--RTTDefaultImpl.mesa -- Paul Rovner, December 21, 1982 3:02 pm DIRECTORY AMBridge USING[TVToLI, TVForPointerReferent, SetTVFromLI, SetTVFromLC, WordSequence, WordSequenceRecord, TVForATOM, IsRemote], AMTypes USING[Class, UnderType, New, IndexToTV, Assign, TypeClass, Error, IndexToType, TVType, TVSize, NComponents, Size], PrincOps USING[ProcDesc, GFTIndex, GlobalFrameHandle, ControlLink], RTBasic USING[Type, Index, TypedVariable, TV], RTCommon USING[ShortenLongPointer], RTSymbolDefs USING[SymbolTableBase, SymbolIndex, SymbolIdIndex, SymbolConstructorIndex, InnerCallableBodyIndex, ExtensionClass, symbolIndexForTYPE, TreeIndex, TreeLink], RTSymbolOps USING[AcquireAtom, EnumerateCtxIseis, AcquireType], RTSymbols USING[GetTypeSymbols, ReleaseSTB], RTTCache USING[RefEntry, LookupRef, GetRef, FillRefEntry], RTTypesPrivate USING[GetTVZones, TypedVariableRec, RecordComponentISEI]; RTTDefaultImpl: PROGRAM IMPORTS AMBridge, AMTypes, RTCommon, RTSymbolOps, RTSymbols, RTTCache, RTTypesPrivate EXPORTS AMTypes, RTTypesPrivate = BEGIN OPEN AMBridge, AMTypes, RTBasic, RTSymbolDefs, RTSymbolOps, RTSymbols; -- C O N S T A N T S tvqZone: ZONE = RTTypesPrivate.GetTVZones[].qz; -- raises notImplemented DefaultInitialValue: PUBLIC SAFE PROC[type: Type] RETURNS[tv: TypedVariable] = TRUSTED {uType: Type _ UnderType[type]; c: Class _ TypeClass[uType]; typeSTB: SymbolTableBase; typeSEI: SymbolIndex; entry: RTTCache.RefEntry; valid: BOOL; Nature: TYPE = {basic, constructed, nil}; n: Nature _ SELECT c FROM record, structure => constructed, unspecified, enumerated, subrange, ref, list, atom, rope, pointer, longPointer, nil, cardinal, integer, character, longInteger, longCardinal, real => IF TypeClass[type] = definition THEN basic ELSE nil, ENDCASE => ERROR Error[reason: notImplemented, msg: "DefaultInitialValue for this type"]; IF n = nil THEN RETURN[NIL]; entry _ RTTCache.LookupRef[type, DefaultInitialValue]; [tv, valid] _ RTTCache.GetRef[entry]; IF valid THEN RETURN [tv]; [typeSTB, typeSEI] _ GetTypeSymbols[type]; {ENABLE UNWIND => ReleaseSTB[typeSTB]; tv _ New[uType]; SELECT n FROM constructed => {index: Index _ 0; iTV, defTV: TypedVariable; csei: SymbolConstructorIndex = typeSTB.UnderType[typeSEI]; EachIndex: PROC[stb: SymbolTableBase, isei: SymbolIdIndex] RETURNS[stop: BOOLEAN] = {index _ index + 1; iTV _ IndexToTV[tv, index]; IF stb.seb[isei].extended THEN {ttype: ExtensionClass; tree: TreeLink; [ttype, tree] _ stb.FindExtension[isei]; IF ttype = default AND SetTVFromLink[iTV, stb, tree] THEN RETURN[FALSE]}; -- If no default is explicitly given for this field, perhaps its type has a default value. defTV _ DefaultInitialValue[AcquireType[stb, stb.seb[isei].idType] ! Error => {defTV _ NIL; CONTINUE}]; IF defTV # NIL THEN Assign[iTV, defTV]; RETURN[FALSE]}; -- start constructed case here WITH ser: typeSTB.seb[csei] SELECT FROM record => [] _ EnumerateCtxIseis[typeSTB, ser.fieldCtx, EachIndex]; definition => ERROR Error[reason: notImplemented, msg: "DefaultInitialValue for interface records"]; ENDCASE=>ERROR}; -- end constructed case basic => {isei: SymbolIdIndex _ LOOPHOLE[typeSEI, SymbolIdIndex]; -- basic attribute guarantees that type is definition ttype: ExtensionClass; tree: TreeLink; DO sei: SymbolIndex = typeSTB.seb[isei].idInfo; IF typeSTB.seb[isei].extended THEN EXIT; -- found default IF typeSTB.seb[sei].seTag # id THEN GO TO noDefault; isei _ LOOPHOLE[sei, SymbolIdIndex]; ENDLOOP; [ttype, tree] _ typeSTB.FindExtension[isei]; IF ttype # default THEN GO TO noDefault; IF ~SetTVFromLink[tv, typeSTB, tree] THEN tv _ NIL EXITS noDefault => {tv _ NIL}}; ENDCASE => ERROR}; -- end basic case ReleaseSTB[typeSTB]; [] _ RTTCache.FillRefEntry[entry, tv]; RETURN[tv]}; -- Reason for function: DefaultInitialValue[IndexToType[type, index]] doesn't work, -- because it misses explicit field value. -- raises typeFault, badIndex, notImplemented IndexToDefaultInitialValue: PUBLIC SAFE PROC[type: Type, index: Index] RETURNS [tv: TypedVariable _ NIL] = TRUSTED {GetDefaultFieldValue: PROC[stb: SymbolTableBase, isei: SymbolIdIndex] = {IF stb.seb[isei].extended THEN {ttype: ExtensionClass; tree: TreeLink; tv _ New[IndexToType[type, index]]; [ttype, tree] _ stb.FindExtension[isei]; IF ttype = default THEN [] _ SetTVFromLink[tv, stb, tree]} ELSE -- If no default is explicitly given for this field, perhaps its type has a default value. tv _ DefaultInitialValue[AcquireType[stb, stb.seb[isei].idType]]}; -- START IndexToDefaultInitialValue HERE RTTypesPrivate.RecordComponentISEI[type, index, GetDefaultFieldValue]}; -- this guy returns FALSE if it can't figure out the value of the tree, -- otherwise gets the value and assigns it to tv. SetTVFromLink: PROC[tv: TypedVariable, stb: SymbolTableBase, tree: TreeLink] RETURNS[success: BOOLEAN _ TRUE] = {DO WITH oak: tree SELECT FROM literal => {WITH wordLit: oak.info SELECT FROM string => RETURN[FALSE]; -- Mesa can't do it word => WITH val: stb.ltb[wordLit.index] SELECT FROM short => {class: Class = TypeClass[UnderType[TVType[tv]]]; IF class = longCardinal OR class = cardinal THEN SetTVFromLC[tv, LONG[LOOPHOLE[val.value, CARDINAL]]] ELSE SetTVFromLI[tv, LONG[LOOPHOLE[val.value, INTEGER]]]; RETURN[TRUE]}; long => {IF val.length # TVSize[tv] THEN ERROR; Assign[lhs: tv, rhs: TVForPointerReferent[ptr: @val.value, type: TVType[tv], status: readOnly]]; RETURN[TRUE]}; ENDCASE => ERROR; ENDCASE => ERROR}; symbol => {OPEN node: stb.seb[oak.index]; class: Class = TypeClass[UnderType[TVType[tv]]]; IF ~node.constant THEN RETURN[FALSE]; IF node.extended THEN {ttype: ExtensionClass; [ttype, tree] _ stb.FindExtension[oak.index]; IF ttype # value THEN ERROR; -- I (DCS) don't believe any of this. LOOP}; IF class = longCardinal OR class = cardinal THEN SetTVFromLC[tv, LONG[LOOPHOLE[node.idValue, CARDINAL]]] ELSE SetTVFromLI[tv, LONG[LOOPHOLE[node.idValue, INTEGER]]]; RETURN[TRUE]}; subtree => {OPEN node: stb.tb[oak.index]; SELECT node.name FROM nil => {Assign[tv, NIL]; RETURN[TRUE]}; void => RETURN[FALSE]; lengthen => {IF node.attr1 -- ptr to lengthen. forget it. THEN RETURN[FALSE] ELSE RETURN[SetTVFromLink[tv: tv, stb: stb, tree: node.son[1]]]}; clit, mwconst => {IF node.nSons # 1 THEN ERROR; tree _ node.son[1]; -- the one son of an mwconst is guaranteed to be a literal LOOP}; uminus => {IF ~SetTVFromLink[tv: tv, stb: stb, tree: node.son[1]] THEN RETURN[FALSE]; SetTVFromLI[tv, -TVToLI[tv]]; RETURN[TRUE]}; construct => {uT: Type = UnderType[TVType[tv]]; index: TreeIndex _ oak.index; IF stb.tb[index].nSons # 2 THEN ERROR; WITH link: stb.tb[index].son[2] SELECT FROM subtree => index _ link.index; ENDCASE => ERROR; SELECT TypeClass[uT] FROM record, structure => NULL; ENDCASE => ERROR; IF stb.tb[index].name # list OR NComponents[uT] # stb.tb[index].nSons THEN ERROR; FOR i: INTEGER IN [1..stb.tb[index].nSons] DO stv: TypedVariable _ IndexToTV[tv, i]; [] _ SetTVFromLink[stv, stb, stb.tb[index].son[i]]; ENDLOOP; RETURN[TRUE]}; atom => {atom: ATOM _ AcquireAtom[stb, NARROW[node.son[1], TreeLink[hash]].index]; Assign[tv, TVForATOM[atom]]; RETURN[TRUE]}; ENDCASE => RETURN[FALSE]}; ENDCASE => ERROR; ENDLOOP}; -- end of SetTVFromLink -- tv arg is for signal, error and proc constants, to determine the gfi or fh bias -- raises notImplemented, typeFault GetIdConstantValue: PUBLIC PROC[tv: TypedVariable, stb: SymbolTableBase, isei: SymbolIdIndex] RETURNS[ws: WordSequence] = { IF stb.seb[isei].idType = symbolIndexForTYPE THEN {ws _ NEW[WordSequenceRecord[1]]; ws[0] _ LOOPHOLE[AcquireType[stb, isei], WORD]; RETURN}; SELECT stb.XferMode[stb.seb[isei].idType] FROM none => { IF stb.seb[isei].extended THEN { newTV: TV; ttype: ExtensionClass; tree: TreeLink; type: Type = AcquireType[stb, stb.seb[isei].idType]; ws _ NEW[WordSequenceRecord[Size[type]]]; newTV _ TVForPointerReferent[ptr: @ws[0], type: type]; [ttype, tree] _ stb.FindExtension[isei]; IF NOT SetTVFromLink[newTV, stb, tree] THEN ERROR Error[reason: notImplemented, msg: "extended constants"]} ELSE {ws _ NEW[WordSequenceRecord[1]]; ws[0] _ LOOPHOLE[stb.seb[isei].idValue, WORD]; }; RETURN}; signal, error, proc => { popd: PrincOps.ProcDesc; pd: PrincOps.ProcDesc; gfiBase: PrincOps.GFTIndex; IF stb.seb[isei].extended THEN ERROR Error[reason: notImplemented, msg: "extended transfer constants"]; IF IsRemote[tv] THEN ERROR Error[reason: notImplemented, msg: "remote transfer constants"]; ws _ NEW[WordSequenceRecord[1]]; WITH tv SELECT FROM tvr: REF RTTypesPrivate.TypedVariableRec => { WITH h: tvr.head SELECT FROM gfh => gfiBase _ h.gfh.gfi; fh => {bti: InnerCallableBodyIndex = LOOPHOLE[stb.seb[isei].idInfo, InnerCallableBodyIndex]; ws[0] _ LOOPHOLE[h.fh+stb.bb[bti].frameOffset, WORD]; RETURN}; pointer => gfiBase _ LOOPHOLE [RTCommon.ShortenLongPointer[h.ptr], PrincOps.GlobalFrameHandle].gfi; ENDCASE => ERROR Error[reason: typeFault, type: TVType[tv]]; }; ENDCASE => ERROR Error[reason: typeFault, type: TVType[tv]]; popd _ LOOPHOLE[stb.seb[isei].idValue, PrincOps.ProcDesc]; pd _ PrincOps.ControlLink[procedure[gfi: 0, ep: 0, tag: TRUE]]; pd.ep _ popd.ep; pd.gfi _ popd.gfi - 1--Groan-- + gfiBase; ws[0] _ LOOPHOLE[pd, WORD]; RETURN}; ENDCASE => ERROR Error [reason: notImplemented, msg: "other than PROC, SIGNAL and ERROR transfer mode constants"]}; END. Κψ– "Mesa" style˜IprocšΧΟc@œΟk œžœ–žœ’žœBžœžœžœ'žœβžœ=žœ+žœ@žœFžœžœ`žœžœžœGœ žœ%Οnœžœžœžœ žœžœšžœ žœ,žœžœžœžœžœžœžœ|žœ žœžœžœfžœžœžœ9žœžœ0žœžœ•Ÿ œžœ,žœžœKžœ!žœˆžœžœ2žœžœžœ [œwžœžœ žœ žœžœžœžœ œžœžœžœcžœ€žœžœœ*žœ6œ9žœ7žœžœžœœ žœžœžœžœžœžœ;žœžœžœžœžœ#žœžœžœžœžœžœœCžœ ­Ÿœžœžœžœ!žœžœžœŸœžœ2žœžœœžœžœ)žœ[œT)œPHœ2œŸ œžœ@žœ žœžœ žœžœ žœžœžœžœžœžœžœœ#žœžœžœvžœžœ(žœžœžœ žœžœžœžœ žœžœžœ2žœžœžœ žœžœžœžœžœžœžœbžœžœžœžœžœžœjžœžœžœ&œ žœžœžœžœžœžœžœžœžœžœžœžœžœžœ#žœ žœžœžœžœžœžœžœ œžœžœžœžœžœažœžœžœ%;œžœ&žœ5žœžœžœ=žœžœ•žœžœžœžœžœžœAžœžœžœžœ'žœžœžœžœžœ8žœžœžœžœžœ+žœžœžœžœ+žœžœ_žœžœžœžœžœ žœžœžœœwŸœžœžœEžœžœ3žœžœ2žœžœžœ žœ$žœžœ&žœ žœΏžœ„žœžœ9žœžœIžœžœ7žœžœ*žœ¬žœ&žœžœvžœžœžœyžœ%žœžœžœžœ;žœ žœžœtžœ¬žœžœ%žœ1žœΣžœžœRžœžœ@žœpžœB œ žœžœžœ žœžœ«žœ˜υ`—…—0x5v