DIRECTORY AMBridge, AMTypes, BBUrpEval, EvalQuote, InterpreterOps, InterpreterPrivate, List, PPTree, PPTreeOps, ProcessProps, Rope, SymTab; AMHacks: CEDAR PROGRAM IMPORTS AMBridge, AMTypes, BBUrpEval, EvalQuote, InterpreterOps, InterpreterPrivate, List, PPTreeOps, ProcessProps, SymTab = BEGIN ROPE: TYPE = Rope.ROPE; Type: TYPE = AMTypes.Type; TV: TYPE = AMTypes.TV; Tree: TYPE = InterpreterOps.Tree; EvalHead: TYPE = InterpreterOps.EvalHead; nullType: Type = AMTypes.nullType; empty: TV _ AMTypes.GetEmptyTV[]; Reflect: PROC [head: EvalHead, tree: Tree, target: Type _ nullType, data: REF _ NIL] RETURNS [return: TV] -- EvalQuote.EvalQuoteProc -- = BEGIN TRUSTED {return _ AMBridge.TVForReferent[NEW[Reflection _ latest _ [head, tree, target]]]}; END; Reflection: TYPE = RECORD [head: EvalHead, tree: Tree, target: Type]; latest: Reflection; ReturnEmpty: PROC [head: EvalHead, tree: Tree, target: Type _ nullType, data: REF _ NIL] RETURNS [return: TV] -- EvalQuote.EvalQuoteProc -- = BEGIN latest _ [head, tree, target]; return _ empty; END; Up: PROC [head: EvalHead, tree: Tree, target: Type _ nullType, data: REF _ NIL] RETURNS [return: TV] -- EvalQuote.EvalQuoteProc -- = BEGIN args: Tree _ PPTreeOps.NthSon[tree, 2]; arg: TV _ InterpreterOps.Eval[tree: args, head: head]; TRUSTED {return _ AMBridge.TVForReferent[NEW [TV _ arg]]}; END; tvType: Type = CODE[TV]; Down: PROC [head: EvalHead, tree: Tree, target: Type _ nullType, data: REF _ NIL] RETURNS [return: TV] -- EvalQuote.EvalQuoteProc -- = BEGIN args: Tree _ PPTreeOps.NthSon[tree, 2]; arg: TV _ InterpreterOps.Eval[tree: args, head: head, target: tvType]; DO SELECT AMTypes.TypeClass[AMTypes.UnderType[AMTypes.TVType[arg]]] FROM ref => { ra: REF ANY; TRUSTED {ra _ AMBridge.TVToRef[arg]}; WITH ra SELECT FROM tv: TV => RETURN [tv]; ENDCASE; }; ENDCASE; arg _ BBUrpEval.UrpWrongType[head, args, arg, tvType, "Down takes a TV"]; args _ NIL; ENDLOOP; END; TypeOf: PROC [head: EvalHead, tree: Tree, target: Type _ nullType, data: REF _ NIL] RETURNS [return: TV] -- EvalQuote.EvalQuoteProc -- = BEGIN args: Tree _ PPTreeOps.NthSon[tree, 2]; arg: TV _ InterpreterOps.Eval[tree: args, head: head]; type: Type _ AMTypes.TVType[arg]; TRUSTED {return _ AMBridge.TVForType[type]}; END; EnType: PROC [head: EvalHead, tree: Tree, target: Type _ nullType, data: REF _ NIL] RETURNS [return: TV] -- EvalQuote.EvalQuoteProc -- = BEGIN args: Tree _ PPTreeOps.NthSon[tree, 2]; arg: TV _ InterpreterOps.Eval[tree: args, head: head, target: underType]; type: Type _ ForceType[arg, head, tree]; TRUSTED {return _ AMBridge.TVForType[type]}; END; UndefineEQ: PROC [name: ROPE, table: SymTab.Ref _ NIL] = BEGIN IF table = NIL THEN table _ NARROW[List.Assoc[$EvalHead, ProcessProps.GetPropList[]], EvalHead].specials; EvalQuote.Register[name, NIL, table]; END; Undefine: PROC [name: ROPE, table: SymTab.Ref _ NIL] RETURNS [wasDefined: BOOL] = BEGIN IF table = NIL THEN table _ NARROW[List.Assoc[$EvalHead, ProcessProps.GetPropList[]], EvalHead].specials; wasDefined _ table.Delete[name]; END; underType: Type _ AMTypes.UnderType[CODE[Type]]; ropeType: Type _ AMTypes.UnderType[CODE[ROPE]]; ForceType: PROC [tv: TV, head: EvalHead, parent: Tree] RETURNS [Type] = TRUSTED { rtn: TV _ tv; DO ut: Type = AMTypes.UnderType[AMTypes.TVType[rtn]]; IF ut = underType THEN RETURN [AMTypes.TVToType[rtn]]; IF AMTypes.TypeClass[ut] = type THEN RETURN [AMTypes.TVToType[rtn]]; rtn _ BBUrpEval.UrpWrongType[head, parent, rtn, underType, "not Type"] ENDLOOP }; Start: PROC = { EvalQuote.Register["&reflect", Reflect, NIL]; EvalQuote.Register["&returnEmpty", ReturnEmpty, NIL]; EvalQuote.Register["&up", Up, NIL]; EvalQuote.Register["&down", Down, NIL]; EvalQuote.Register["&typeOf", TypeOf, NIL]; EvalQuote.Register["&unCODE", EnType, NIL]; TRUSTED { InterpreterOps.RegisterTV["&undefineEQ", AMBridge.TVForProc[UndefineEQ], "Undoes an EvalQuote registration", InterpreterPrivate.GetGlobalSymTab[]]; InterpreterOps.RegisterTV["&undefine", AMBridge.TVForProc[Undefine], "Removes something from the specials table", InterpreterPrivate.GetGlobalSymTab[]]; }; }; Start[]; END. fAMHacks.Mesa Last Edited by: Spreitzer, May 10, 1986 0:42:55 am PDT Try to get the right stuff. Κξ– "cedar" style˜codešœ ™ K™6—K˜KšΟk œ‚˜‹K˜šΠbxœœ˜Kšœu˜|—K˜Kš˜K˜Kšœœœ˜Kšœœ˜Kšœœ œ˜Kšœœ˜!Kšœ œ˜)Kšœ"˜"Kšœœ˜!K˜šΟnœœ=œœœ œΟcœ˜‰Kš˜Kšœ"œ/˜[Kšœ˜—K˜Kšœ œœ,˜EK˜K˜K˜šŸ œœ=œœœ œ œ˜Kš˜Kšœ˜K˜Kšœ˜—K˜šŸœœ=œœœ œ œ˜„Kš˜Kšœ'˜'Kšœœ/˜6Kšœ"œœ ˜:Kšœ˜—K˜Kšœœœ˜K˜šŸœœ=œœœ œ œ˜†Kš˜Kšœ'˜'Kšœœ?˜Fš˜šœ;˜Ešœ˜Kšœœœ˜ Kšœ˜%šœœ˜Kšœœœ˜Kšœ˜—K˜—Kšœ˜—KšœI˜IKšœœ˜ Kšœ˜—Kšœ˜—K˜šŸœœ=œœœ œ œ˜ˆKš˜Kšœ'˜'Kšœœ/˜6K˜!Kšœ%˜,Kšœ˜—K˜šŸœœ=œœœ œ œ˜ˆKš˜Kšœ'˜'KšœœB˜IK˜(Kšœ%˜,Kšœ˜—K˜šŸ œœœœ˜8Kš˜Kšœ œœ œG˜iKšœœ ˜%Kšœ˜—K˜š Ÿœœœœœœ˜QKš˜Kšœ œœ œG˜iKšœ ˜ Kšœ˜—K˜Kšœ$œ˜0Kšœ#œœ˜/K˜š Ÿ œœœ œ œ˜QKšœœ˜ š˜Kšœ™Kšœ2˜2Kšœœœ˜6Kšœœœ˜DKšœF˜FKš˜—K˜—K˜šŸœœ˜Kšœ(œ˜-Kšœ0œ˜5Kšœœ˜#Kšœ"œ˜'Kšœ&œ˜+Kšœ&œ˜+šœ˜ Kšœ“˜“Kšœ˜˜˜K˜—K˜—K˜K˜K˜Kšœ˜—…—h