<> <> DIRECTORY AMBridge, AMModel, AMModelBridge, AMTypes, Atom, BackStop, BBUrpEval, Commander, EvalQuote, Interpreter, InterpreterOps, IO, List, Misp, ProcessProps, Rope, RTTypesPrivate, StatementInterpreter, SymTab; MispCedar: CEDAR PROGRAM IMPORTS AMBridge, AMModel, AMModelBridge, AMTypes, Atom, BackStop, BBUrpEval, EvalQuote, Interpreter, InterpreterOps, IO, List, Misp, ProcessProps, Rope, StatementInterpreter, SymTab ={ LORA: TYPE = LIST OF REF ANY; ROPE: TYPE = Rope.ROPE; TV: TYPE = AMTypes.TV; ReallyTV: TYPE = REF RTTypesPrivate.TypedVariableRec; <> EvalCedarExpr: PROC [args: LORA, environment: Misp.Environment, data: REF ANY _ NIL, stack: Misp.Stack] RETURNS [cooked: REF ANY] --Misp.EvalProc-- = { cedarExpression: ROPE _ NARROW[args.first]; symTab: SymTab.Ref _ Symtabize[environment]; result: TV; errorRope: ROPE; noResult: BOOL; [result, errorRope, noResult] _ Interpreter.Evaluate[ rope: cedarExpression, symTab: symTab, abort: Misp.EnvStop[environment] ]; IF errorRope.Length[] # 0 THEN ERROR Misp.Error[environment, stack, errorRope]; cooked _ IF NOT noResult THEN CedarToMisp[result] ELSE NIL; }; EvalCedarStmt: PROC [args: LORA, environment: Misp.Environment, data: REF ANY _ NIL, stack: Misp.Stack] RETURNS [cooked: REF ANY] --Misp.EvalProc-- = { cedarStatement: ROPE _ NARROW[args.first]; symTab: SymTab.Ref _ Symtabize[environment]; errorRope: ROPE; cooked _ NIL; errorRope _ StatementInterpreter.InterpretStatement[ blockAsRope: cedarStatement, symTab: symTab, abort: Misp.EnvStop[environment] !Yield => { cooked _ CedarToMisp[value]; CONTINUE } ]; IF errorRope.Length[] # 0 THEN ERROR Misp.Error[environment, stack, errorRope]; }; Yield: ERROR [value: TV] = CODE; EvalYield: PROC [head: InterpreterOps.EvalHead, tree: InterpreterOps.Tree, target: AMTypes.Type _ AMTypes.nullType, data: REF _ NIL] RETURNS [return: TV] --EvalQuote.EvalQuoteProc-- = { argTree: InterpreterOps.Tree _ InterpreterOps.GetArg[tree, 1]; argTV: TV _ InterpreterOps.Eval[tree: argTree, head: head, target: target]; BackStop.SuspendBackStop[]; ERROR Yield[argTV]; }; Symtabize: PROC [env: Misp.Environment] RETURNS [symTab: SymTab.Ref] = { size: NAT _ 0; FOR e: Misp.Environment _ env, e.parent WHILE e # NIL DO size _ size + e.class.Size[e]; ENDLOOP; size _ size*2 + 1; symTab _ SymTab.Create[size]; FOR e: Misp.Environment _ env, e.parent WHILE e # NIL DO Per: PROC [key: ATOM, binding: REF ANY] = { name: ROPE _ Atom.GetPName[key]; [] _ symTab.Insert[name, MispToCedar[binding]]; }; e.class.Enumerate[e, Per]; ENDLOOP; }; DefineCedar: PROC [environment: Misp.Environment] = { environment.Defun[$cedarExpr, EvalCedarExpr]; environment.Defun[$cedarStmt, EvalCedarStmt]; }; <> EvalMisp: PROC [head: InterpreterOps.EvalHead, tree: InterpreterOps.Tree, target: AMTypes.Type _ AMTypes.nullType, data: REF _ NIL] RETURNS [return: TV] --EvalQuote.EvalQuoteProc-- = { argTree: InterpreterOps.Tree _ InterpreterOps.GetArg[tree, 1]; argTV: TV _ InterpreterOps.Eval[tree: argTree, head: head]; argRef, raw, cooked: REF ANY; env: Misp.Environment _ Environmentize[head]; TRUSTED {argRef _ CedarToMisp[argTV]}; WITH argRef SELECT FROM rope: ROPE => raw _ GetStreamRefAny[IO.RIS[rope]]; text: REF TEXT => raw _ GetStreamRefAny[IO.TIS[text]]; ENDCASE => raw _ argRef; BackStop.SuspendBackStop[]; cooked _ Misp.Eval[raw: raw, environment: env, stack: NIL ! Misp.Error => { BackStop.ResumeBackStop[]; BBUrpEval.UrpFatal[head, tree, IO.PutFR["Misp: %g, stack = %g", IO.rope[msg], IO.rope[Misp.PrintValRope[stack]]]]; ERROR; }; UNWIND => BackStop.ResumeBackStop[] ]; BackStop.ResumeBackStop[]; return _ MispToCedar[cooked]; }; GetStreamRefAny: PROC [s: IO.STREAM] RETURNS [ra: REF ANY] = { ra _ s.GetRefAny[]; [] _ s.SkipWhitespace[]; IF NOT s.EndOf[] THEN ERROR; s.Close[]; }; Environmentize: PROC [head: InterpreterOps.EvalHead] RETURNS [env: Misp.Environment] = { cc: AMModel.Class; DoRecord: PROC [tv: TV, name: ROPE] = {IF tv # NIL THEN env _ Misp.NewEnvironment[name: name, parent: env, class: recordClass, initData: tv]}; in, out: IO.STREAM _ NIL; WITH List.Assoc[$CommanderHandle, ProcessProps.GetPropList[]] SELECT FROM cmd: Commander.Handle => {in _ cmd.in; out _ cmd.out}; ENDCASE; env _ Misp.NewEnvironment[name: "Standard Misp stuff for a Cedar evaluation", in: in, out: out, sizeGuess: 200, stop: head.abortClosure]; Misp.DefinePrimitives[env]; TRUSTED {cc _ AMModel.ContextClass[head.context]}; SELECT cc FROM world => NULL --don't define the Cedar world for Misp ... it can't use it--; model => ERROR --don't know how to break down a CONFIG--; statement => ERROR --don't know how to break down a statement--; interface => TRUSTED { DoRecord[ AMModelBridge.IRFromContext[head.context], AMModel.ContextName[head.context]]; }; prog => TRUSTED { DoRecord[ AMTypes.Globals[AMModelBridge.FrameFromContext[head.context]], AMModel.ContextName[head.context]]; }; proc => TRUSTED { context: TV _ AMModelBridge.FrameFromContext[head.context]; Work: UNSAFE PROC [tv: TV] = { IF tv # NIL THEN { Work[AMTypes.EnclosingBody[tv]]; DoRecord[ AMTypes.Locals[tv], AMTypes.TVToName[AMTypes.Procedure[tv]] ]; } ELSE DoRecord[ AMTypes.Globals[AMTypes.GlobalParent[context]], AMModel.ContextName[AMModel.ParentContext[context]] ]; }; Work[context]; }; ENDCASE => ERROR; env _ Misp.NewEnvironment[name: "Cedar specials", parent: env, class: symtabClass, initData: head.specials]; }; recordClass: Misp.EnvironmentClass _ NEW [Misp.EnvironmentClassRep _ [ Init: InitRecord, GetBinding: GetRecordBinding, SetBinding: SetRecordBinding, Enumerate: EnumerateRecord, Size: RecordSize]]; InitRecord: PROC [env: Misp.Environment, sizeGuess: NAT, initData: REF ANY] = { env.rep _ initData; }; GetRecordBinding: PROC [env: Misp.Environment, key: ATOM] RETURNS [found: BOOL, binding: REF ANY] = { name: ROPE _ Atom.GetPName[key]; record: TV _ NARROW[env.rep]; type: AMTypes.Type _ AMTypes.TVType[record]; index: CARDINAL; valTV: TV; found _ TRUE; index _ AMTypes.NameToIndex[type, name !AMTypes.Error => {IF reason = badName THEN {found _ FALSE; CONTINUE}};]; IF NOT found THEN RETURN; valTV _ AMTypes.IndexToTV[record, index]; binding _ CedarToMisp[valTV]; }; SetRecordBinding: PROC [env: Misp.Environment, key: ATOM, binding: REF ANY, overwriteOld: BOOL] = { name: ROPE _ Atom.GetPName[key]; record: TV _ NARROW[env.rep]; type: AMTypes.Type _ AMTypes.TVType[record]; index: CARDINAL; varTV, valTV: TV; found: BOOL _ TRUE; index _ AMTypes.NameToIndex[type, name !AMTypes.Error => {IF reason = badName THEN {found _ FALSE; CONTINUE}};]; IF NOT found THEN ERROR Misp.Error[env, NIL, "Can't add fields to a Cedar frame"]; varTV _ AMTypes.IndexToTV[record, index]; SELECT AMTypes.TVStatus[varTV] FROM mutable => NULL; readOnly, const => ERROR Misp.Error[env, NIL, Rope.Cat["Can't update ", name]]; ENDCASE => ERROR; valTV _ MispToCedar[binding]; AMTypes.Assign[varTV, valTV]; }; EnumerateRecord: PROC [env: Misp.Environment, consume: PROC [key: ATOM, binding: REF ANY]] = { record: TV _ NARROW[env.rep]; type: AMTypes.Type _ AMTypes.TVType[record]; n: NAT _ AMTypes.NComponents[type]; FOR i: NAT IN [1 .. n] DO name: ROPE _ AMTypes.IndexToName[type, i]; key: ATOM _ Atom.MakeAtom[name]; valTV: TV _ AMTypes.IndexToTV[record, i]; valRef: REF ANY _ CedarToMisp[valTV]; consume[key, valRef]; ENDLOOP; n _ n; }; RecordSize: PROC [env: Misp.Environment] RETURNS [NAT] = { record: TV _ NARROW[env.rep]; type: AMTypes.Type _ AMTypes.TVType[record]; n: NAT _ AMTypes.NComponents[type]; RETURN [n]; }; symtabClass: Misp.EnvironmentClass _ NEW [Misp.EnvironmentClassRep _ [ Init: InitSymtab, GetBinding: GetSymtabBinding, SetBinding: SetSymtabBinding, Enumerate: EnumerateSymtab, Size: SymtabSize]]; InitSymtab: PROC [env: Misp.Environment, sizeGuess: NAT, initData: REF ANY] = { env.rep _ initData; }; GetSymtabBinding: PROC [env: Misp.Environment, key: ATOM] RETURNS [found: BOOL, binding: REF ANY] = { name: ROPE _ Atom.GetPName[key]; symtab: SymTab.Ref _ NARROW[env.rep]; tv: TV; [found, tv] _ symtab.Fetch[name]; IF NOT (found AND ISTYPE[tv, ReallyTV]) THEN RETURN [FALSE, NIL]; binding _ CedarToMisp[tv]; }; SetSymtabBinding: PROC [env: Misp.Environment, key: ATOM, binding: REF ANY, overwriteOld: BOOL] = { name: ROPE _ Atom.GetPName[key]; symtab: SymTab.Ref _ NARROW[env.rep]; tv: TV; tv _ MispToCedar[binding]; [] _ (IF overwriteOld THEN SymTab.Store ELSE SymTab.Insert)[symtab, name, tv]; }; EnumerateSymtab: PROC [env: Misp.Environment, consume: PROC [key: ATOM, binding: REF ANY]] = { symtab: SymTab.Ref _ NARROW[env.rep]; PerPair: PROC [key: ROPE, val: REF ANY] RETURNS [quit: BOOL] --SymTab.EachPairAction-- = { atom: ATOM _ Atom.MakeAtom[key]; WITH val SELECT FROM tv: ReallyTV => { binding: REF ANY _ CedarToMisp[tv]; consume[atom, binding]; }; ENDCASE; quit _ FALSE; }; [] _ symtab.Pairs[PerPair]; symtab _ symtab}; SymtabSize: PROC [env: Misp.Environment] RETURNS [NAT] = { symtab: SymTab.Ref _ NARROW[env.rep]; RETURN [symtab.GetSize[]]; }; <> <> <> <> <> <<};>> <<>> <> <> <> <> <> <> <<>> <> <> <<};>> <<>> <> <> <> <> <> <> <<[valTV, errorRope, noResult] _ Interpreter.Evaluate[>> <> <> <> <> <> <<};>> <<>> <> <> <> <> <> <> <<[varTV, errorRope, noResult] _ Interpreter.Evaluate[>> <> <> <> <> <> <> <> <> <<};>> <<>> <> <> <> <> <> <> <> <> <> <> <> <> <> <<};>> <> <> < {>> <> <> <> <<};>> <> <> <<};>> <> <<[] _ InterpreterOps.EnumerateSymbols[PerSpecial, NIL, head.specials];>> <> < NULL --don't define the Cedar world for Misp ... it can't use it--;>> < ERROR --don't know how to break down a CONFIG--;>> < ERROR --don't know how to break down a statement--;>> < FromRecord[AMModelBridge.IRFromContext[head.context]];>> < FromRecord[AMTypes.Globals[AMModelBridge.FrameFromContext[head.context]]];>> < {>> <> <> <> <> <> <<};>> < ERROR;>> <<>> <<};>> <<>> <> <> <> <> <> <> <<};>> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <<};>> <> <> <> <> <> <<};>> <> <> < NULL --don't define the Cedar world for Misp ... it can't use it--;>> < ERROR --don't know how to break down a CONFIG--;>> < ERROR --don't know how to break down a statement--;>> < TRUSTED {>> <> <> <> <<};>> < TRUSTED {>> <> <> <> <<};>> < TRUSTED {>> <> <> <> <> <> <> <<};>> < ERROR;>> <> <> <> <<[] _ InterpreterOps.EnumerateSymbols[PerSpecial, NIL, head.specials];>> <> < NULL --don't define the Cedar world for Misp ... it can't use it--;>> < ERROR --don't know how to break down a CONFIG--;>> < ERROR --don't know how to break down a statement--;>> < FromRecord[context];>> < FromRecord[context];>> < {>> <> <> <> <> <<};>> < ERROR;>> <<};>> <> ROPEType: AMTypes.Type _ AMTypes.UnderType[CODE[ROPE]]; ATOMType: AMTypes.Type _ AMTypes.UnderType[CODE[ATOM]]; CedarToMisp: PROC [tv: TV] RETURNS [ref: REF ANY] = TRUSTED { class: AMTypes.Class _ AMTypes.UnderClass[AMTypes.TVType[tv]]; SELECT class FROM < ref _ AMBridge.TVToATOM[tv];>> < ref _ AMTypes.TVToName[tv];>> < ref _ AMBridge.SomeRefFromTV[>> <> < IF reason = typeFault THEN {>> <> < ref _ AMTypes.TVToName[tv];>> < ref _ AMBridge.TVToATOM[tv];>> < ref _ AMBridge.SomeRefFromTV[tv];>> <> <<]>> <<];>> atom, rope, list, ref => ref _ AMBridge.TVToRef[tv]; nil => ref _ NIL; ENDCASE => ref _ AMBridge.SomeRefFromTV[tv]; }; MispToCedar: PROC [ref: REF ANY] RETURNS [tv: TV] = TRUSTED { tv _ AMBridge.TVForReferent[NEW [REF ANY _ ref], const]; }; Start: PROC = { Misp.RegisterPrimitiveDefiner[DefineCedar]; EvalQuote.Register[name: "&yield", proc: EvalYield, symTab: NIL]; EvalQuote.Register[name: "&misp", proc: EvalMisp, symTab: NIL]; }; Start[]; }.