<> <> DIRECTORY AMBridge, AMModel, AMTypes, BackStop, BBUrpEval, CBinary, Commander, CommandExtras, CommandTool, EvalQuote, Interpreter, InterpreterOps, InterpreterPrivate, IO, List, PPLeaves, PPP1, PPTree, PPTreeOps, PrincOps, PrincOpsUtils, PrintTV, ProcessProps, Real, Rope, SafeStorage, StatementInterpreter, StatementInterpreterPrivate, SymTab, WorldVM; TransferStatements: CEDAR PROGRAM IMPORTS AMBridge, AMTypes, BBUrpEval, InterpreterOps, IO, PPTreeOps, PrincOpsUtils, PrintTV, Rope, SafeStorage, StatementInterpreterPrivate, SymTab, WorldVM EXPORTS StatementInterpreter, StatementInterpreterPrivate = BEGIN OPEN StatementInterpreterPrivate; emptyFields: Fields _ NEW[FieldsRep[0]]; CatchSeries: TYPE = REF CatchSeriesRep; CatchSeriesRep: TYPE = RECORD [ arms: SEQUENCE length: NAT OF CatchArm]; CatchArm: TYPE = REF CatchArmRep; CatchArmRep: TYPE = RECORD [ stmt: Tree, theSigType: Type, multipleSigTypes: BOOL, signals: SEQUENCE length: NAT--0 is for the ANY arm-- OF Signal ]; Signal: TYPE = ERROR ANY RETURNS ANY; Decide: PROC [catchSeries: CatchSeries, sig: Signal, lftv: TV, head: EvalHead] RETURNS [sd: SignalDecision] = { TryCatch: PROC [catch: CatchArm] RETURNS [caught: BOOL] = { caught _ FALSE; IF catch.length = 0 THEN caught _ TRUE ELSE FOR i: NAT IN [0 .. catch.length) WHILE NOT caught DO IF catch.signals[i] = sig THEN caught _ TRUE; ENDLOOP; IF caught THEN sd _ ProcessStmt[ catch.stmt, IF catch.multipleSigTypes THEN nullType ELSE catch.theSigType, lftv, head]; }; FOR i: NAT IN [0 .. catchSeries.length) DO IF TryCatch[catchSeries[i]] THEN RETURN; ENDLOOP; sd _ [Reject]; }; ProcessStmt: PROC [stmt: Tree, sigType: Type, lftv: TV, head: EvalHead] RETURNS [sd: SignalDecision] = { subHead: EvalHead _ NestHead[head]; argsType, resultsType: Type _ nullType; IF sigType # nullType THEN { argsType _ AMTypes.Domain[sigType]; SELECT AMTypes.TypeClass[sigType] FROM signal => resultsType _ AMTypes.Range[sigType]; error => resultsType _ nullType; ENDCASE => ERROR; SetupFrame[subHead, argsType, resultsType, lftv]; }; sd _ [Reject]; InterpNoProps[stmt, subHead ! DecideSignal => {sd _ [decision]; CONTINUE}; Resume => {sd _ [type: Resume, fields: fields]; CONTINUE}; Return => <> BBUrpEval.UrpFatal[subHead, stmt, "Can't RETURN out of a catch phrase"]; <> <<{sd _ [type: Return, fields: fields]; CONTINUE};>> Exit => {sd _ [Exit]; CONTINUE}; Loop => {sd _ [Loop]; CONTINUE}; GoTo => {sd _ [type: GoTo, label: label]; CONTINUE}; ]; IF sd.type = Resume THEN { CloseupFrame[resultsType, sd.fields, lftv, "Catch phrase", subHead, stmt, subHead.specials]; }; }; DigestCatchSeries: PROC [catch: Node, head: EvalHead] RETURNS [cs: CatchSeries] = { catchRegular: Node _ NARROW[catch.son[1]]; catchAny: Node _ NARROW[catch.son[2]]; anyPresent: BOOL _ catchAny # NIL; numRegulars: NAT _ PPTreeOps.ListLength[catchRegular]; armIndex: NAT _ 0; PerCatch: PROC [t: Tree] = { item: Node _ NARROW[t]; names: Tree _ item.son[1]; stmt: Tree _ item.son[2]; numNames: NAT _ PPTreeOps.ListLength[names]; nameIndex: NAT _ 0; PerName: PROC [t: Tree] = { armtv: TV; armType: Type; armtv _ EvalExpr[tree: t, head: head, target: cs[armIndex].theSigType]; armType _ AMTypes.UnderType[AMTypes.TVType[armtv]]; IF NOT AMTypes.TypeClass[armType] IN [signal .. error] THEN BBUrpEval.UrpFatal[head, t, "Not a signal or error"]; TRUSTED {cs[armIndex].signals[nameIndex] _ AMBridge.TVToSignal[armtv]}; IF cs[armIndex].theSigType = nullType THEN cs[armIndex].theSigType _ armType ELSE IF cs[armIndex].multipleSigTypes THEN NULL ELSE IF NOT SafeStorage.EquivalentTypes[cs[armIndex].theSigType, armType] THEN cs[armIndex].multipleSigTypes _ TRUE; nameIndex _ nameIndex + 1; }; cs[armIndex] _ NEW [CatchArmRep[numNames]]; cs[armIndex].stmt _ stmt; cs[armIndex].theSigType _ nullType; cs[armIndex].multipleSigTypes _ FALSE; PPTreeOps.ScanList[names, PerName]; IF nameIndex # numNames THEN ERROR; armIndex _ armIndex + 1; }; cs _ NEW [CatchSeriesRep[numRegulars + (IF anyPresent THEN 1 ELSE 0)]]; PPTreeOps.ScanList[catchRegular, PerCatch]; IF armIndex # numRegulars THEN ERROR; IF anyPresent THEN { cs[armIndex] _ NEW [CatchArmRep[0]]; cs[armIndex].stmt _ catchAny; cs[armIndex].theSigType _ nullType; cs[armIndex].multipleSigTypes _ FALSE; armIndex _ armIndex + 1; }; }; Enable: PUBLIC PROC [catches: Node, head: EvalHead, inner: PROC] = { catchSeries: CatchSeries; sd: SignalDecision _ [Continue]; IF catches.name # catch THEN ERROR; catchSeries _ DigestCatchSeries[catches, head]; inner[! UNWIND => { lf: PrincOps.FrameHandle; lftv: TV; TRUSTED { lf _ PrincOpsUtils.MyLocalFrame[]; lftv _ AMBridge.TVForFrame[fh: lf]; }; sd _ Decide[catchSeries: catchSeries, sig: UNWIND, lftv: lftv, head: head]; SELECT sd.type FROM Reject => REJECT; Retry => RETRY; Continue, Return, Exit, Loop, GoTo => CONTINUE; Resume => BBUrpEval.UrpFatal[head, catches, "RESUMEing not yet implemented"]; ENDCASE => ERROR; }; ANY => { lf: PrincOps.FrameHandle; lftv, sigtv: TV; sig: Signal; TRUSTED { lf _ PrincOpsUtils.MyLocalFrame[]; lftv _ AMBridge.TVForFrame[fh: lf]; sigtv _ AMTypes.Signal[lftv]; sig _ AMBridge.TVToSignal[sigtv]; }; sd _ Decide[catchSeries: catchSeries, sig: sig, lftv: lftv, head: head]; SELECT sd.type FROM Reject => REJECT; Retry => RETRY; Continue, Return, Exit, Loop, GoTo => CONTINUE; Resume => BBUrpEval.UrpFatal[head, catches, "RESUMEing not yet implemented"]; ENDCASE => ERROR; } ]; SELECT sd.type FROM Reject => NULL; Retry => NULL; Continue => NULL; Resume => NULL; Return => ERROR Return[sd.fields]; Exit => ERROR Exit[]; Loop => ERROR Loop[]; GoTo => ERROR GoTo[sd.label]; ENDCASE => ERROR; }; SetupFrame: PROC [head: EvalHead, argsType, resultsType: Type, frameTV: TV] = { nArgs, nResults: NAT; nArgs _ SELECT AMTypes.TypeClass[argsType] FROM record, structure => AMTypes.NComponents[argsType], nil => 0, ENDCASE => ERROR; nResults _ SELECT AMTypes.TypeClass[resultsType] FROM record, structure => AMTypes.NComponents[resultsType], nil => 0, ENDCASE => ERROR; FOR i: NAT IN [1 .. nArgs] DO name: ROPE _ AMTypes.IndexToName[argsType, i]; val: TV; IF name.Length[] = 0 THEN LOOP; val _ AMTypes.Argument[frameTV, i]; [] _ SymTab.Store[head.specials, name, AMTypes.Copy[val]]; ENDLOOP; FOR i: NAT IN [1 .. nResults] DO name: ROPE _ AMTypes.IndexToName[resultsType, i]; val: TV; IF name.Length[] = 0 THEN LOOP; val _ AMTypes.IndexToDefaultInitialValue[resultsType, i]; [] _ SymTab.Store[ head.specials, name, IF val # NIL THEN AMTypes.Copy[val] ELSE AMTypes.New[AMTypes.IndexToType[resultsType, i]] ]; ENDLOOP; }; CloseupFrame: PROC [resultsType: Type, results: Fields, frameTV: TV, lname: ROPE, head: EvalHead, parent: Tree, table: SymbolTable] = { formalResults: Fields _ FieldsFromType[resultsType]; matchedResults: Fields _ SafeMatch[formalResults, results, lname, head, parent, table]; FOR i: NAT IN [0 .. formalResults.length) DO val, var: TV; val _ matchedResults[i].value; var _ AMTypes.Result[frameTV, i+1]; AMTypes.Assign[var, val]; ENDLOOP; }; FieldsFromType: PROC [type: Type] RETURNS [fields: Fields] = { n: NAT; someNamed: BOOL _ FALSE; allNamed: BOOL _ TRUE; n _ SELECT AMTypes.TypeClass[type] FROM record, structure => AMTypes.NComponents[type], nil => 0, ENDCASE => ERROR; fields _ NEW [FieldsRep[n]]; FOR i: NAT IN [0 .. n) DO fields[i].name _ AMTypes.IndexToName[type, i+1]; IF fields[i].name.Length[] # 0 THEN someNamed _ TRUE ELSE allNamed _ FALSE; fields[i].type _ AMTypes.IndexToType[type, i+1]; fields[i].typed _ TRUE; fields[i].value _ AMTypes.IndexToDefaultInitialValue[type, i+1]; fields[i].valued _ fields[i].value # NIL; ENDLOOP; IF (n>0) AND (someNamed # allNamed) THEN ERROR; fields.named _ someNamed; }; DigestFields: PUBLIC PROC [tree: Tree, eval, mayNIL: BOOLEAN, head: EvalHead _ NIL] RETURNS [fields: Fields] = BEGIN Op: TYPE = {Count, Fill}; count, index: NAT _ 0; op: Op; someNamed: BOOLEAN _ FALSE; allNamed: BOOLEAN _ TRUE; DoIt: PPTree.Scan --PROC [t: Link]-- = BEGIN SELECT PPTreeOps.OpName[t] FROM decl => Work[PPTreeOps.NthSon[t, 1], PPTreeOps.NthSon[t, 2], PPTreeOps.NthSon[t, 3]]; item => Work[PPTreeOps.NthSon[t, 1], NIL, PPTreeOps.NthSon[t, 2]]; ENDCASE => Work[NIL, NIL, t]; END; Work: PROCEDURE [name, type, value: Tree] = BEGIN RealWork: PPTree.Scan --PROC [t: Link]-- = BEGIN name: Tree = t; SELECT op FROM Count => count _ count + 1; Fill => BEGIN IF name # NIL THEN BEGIN someNamed _ TRUE; fields[index].name _ InterpreterOps.TreeToName[name] END ELSE BEGIN allNamed _ FALSE; fields[index].name _ NIL; END; fields[index].type _ IF (fields[index].typed _ type # NIL) THEN ForceType[EvalExpr[type, head, typeType], head, type] ELSE nullType; IF NOT (fields[index].valued _ value # NIL) THEN NULL ELSE IF NOT eval THEN fields[index].value _ value ELSE fields[index].value _ EvalExpr[value, head, fields[index].type]; index _ index + 1; END; ENDCASE => ERROR; END; IF name = NIL THEN RealWork[NIL] ELSE PPTreeOps.ScanList[name, RealWork]; END; IF mayNIL AND (tree = NIL) THEN RETURN [NIL]; op _ Count; PPTreeOps.ScanList[tree, DoIt]; fields _ NEW [FieldsRep[count]]; op _ Fill; PPTreeOps.ScanList[tree, DoIt]; IF (someNamed # allNamed) AND count > 0 THEN ERROR; fields.named _ someNamed; END; EvalReturn: PUBLIC PROC [rn: Node, head: EvalHead] = { fields: Fields; fields _ DigestFields[rn.son[1], TRUE, TRUE, head]; ERROR Return[fields]; }; EvalResume: PUBLIC PROC [rn: Node, head: EvalHead] = { fields: Fields; fields _ DigestFields[rn.son[1], TRUE, TRUE, head]; ERROR Resume[fields]; }; EvalProcedure: PUBLIC PROC [head: EvalHead, tree: Tree, target: Type _ nullType, data: REF _ NIL] RETURNS [return: TV] --EvalQuote.EvalQuoteProc-- = BEGIN args: Tree; actualFields, matchedArgs, ans: Fields _ NIL; l: Lambda _ NARROW[data]; subHead: EvalHead; IF PPTreeOps.OpName[tree] # apply THEN ERROR; args _ PPTreeOps.NthSon[tree, 2]; actualFields _ DigestFields[args, TRUE, FALSE, head]; matchedArgs _ SafeMatch[l.args, actualFields, l.name.Cat[".Args"], head, tree, NIL]; subHead _ NestHead[head, l.symbols]; Bind[subHead.specials, matchedArgs]; Bind[subHead.specials, l.rets]; [] _ InterpNoProps[l.body, subHead ! Return => {ans _ fields; CONTINUE}; DecideSignal, Resume, Exit, Loop, GoTo => {BBUrpEval.UrpFatal[head, tree, "Can't EXIT, LOOP, GOTO, REJECT, RESUME, RETRY, or CONTINUE out of a procedure body"]; CONTINUE}]; SELECT l.rets.length FROM 0 => { IF ans # NIL AND ans.length # 0 THEN BBUrpEval.UrpFatal[head, tree, Rope.Cat["Values returned to ", l.name, ", who wasn't expecting them"]]; return _ empty; }; 1 => { matchedRets: Fields _ SafeMatch[l.rets, ans, l.name.Cat[".Results"], subHead, tree, subHead.specials]; return _ matchedRets[0].value; <> <<0 => {>> <> <> <> <<[found, return] _ subHead.specials.Fetch[l.rets[0].name];>> <> <> <> <> <> <> <> <> <> <> <<};>> <<1 => {>> <> <<};>> < BBUrpEval.UrpFatal[head, tree, "Too many values returned"];>> <> <> <> <> <> < {need _ TRUE; CONTINUE}];>> <> <> <> }; ENDCASE => ERROR; END; SafeMatch: PROC [formals, actuals: Fields, lname: ROPE, head: EvalHead, parent: Tree, table: SymbolTable] RETURNS [bound: Fields] = BEGIN bound _ Match[formals, actuals, lname, table ! MatchWarning => {BBUrpEval.UrpFatal[head, parent, IO.PutFR[fmt, v1, v2, v3, v4]]; CONTINUE}; MatchError => {BBUrpEval.UrpFatal[head: head, parent: parent, msg: IO.PutFR[format, v1, v2, v3, v4]]; CONTINUE}]; END; MatchWarning: SIGNAL [fmt: ROPE, v1, v2, v3, v4: IO.Value _ [null[]]] = CODE; MatchError: ERROR [format: ROPE, v1, v2, v3, v4: IO.Value _ [null[]]] = CODE; MissType: TYPE = {elide, omit}; Match: PROC [formals, actuals: Fields, lname: ROPE, table: SymbolTable] RETURNS [bound: Fields] = BEGIN Miss: PROC [i: NAT, how: MissType] = { IF formals[i].valued THEN {bound[i].valued _ TRUE; bound[i].value _ formals[i].value; RETURN} ELSE IF formals[i].typed THEN { div: TV _ AMTypes.DefaultInitialValue[formals[i].type]; IF div # NIL THEN {bound[i].valued _ TRUE; bound[i].value _ div; RETURN}; } ELSE ERROR --formals must have types, right?--; SELECT how FROM elide => {v: TV _ AMTypes.New[formals[i].type]; bound[i].valued _ TRUE; bound[i].value _ v; RETURN}; omit => ERROR MatchError["%g omitted", IO.rope[Describe[i]]]; ENDCASE; }; SetValue: PROC [j, i: NAT] = BEGIN bound[j].valued _ TRUE; IF NOT bound[j].typed THEN bound[j].value _ actuals[i].value ELSE bound[j].value _ AMTypes.Coerce[ tv: actuals[i].value, targetType: bound[j].type ! AMTypes.Error => {msgs: IO.STREAM _ IO.ROS[]; msgs.PutF["Type mismatch at %g: expecting a ", IO.rope[Describe[j]]]; PrintTV.PrintType[bound[j].type, msgs]; msgs.PutRope[", got "]; PrintTV.Print[actuals[i].value, msgs]; ERROR MatchError[IO.RopeFromROS[msgs]]}]; END; Describe: PROC [i: NAT] RETURNS [ROPE] = {RETURN[IF bound.named THEN IO.PutFR["%g.%g", IO.rope[lname], IO.rope[bound[i].name]] ELSE IO.PutFR["%g'th %g", IO.card[i], IO.rope[lname]]]}; bound _ UnvalueFields[formals]; IF actuals = NIL THEN { IF table = NIL THEN ERROR; IF bound.length = 0 THEN RETURN; IF NOT bound.named THEN MatchError["Default return or resume of unnamed fields from %g", IO.rope[lname]]; FOR i: NAT IN [0 .. bound.length) DO found: BOOL; val: TV; [found, val] _ table.Fetch[bound[i].name]; IF NOT found THEN ERROR --should have been initialized, right?--; bound[i].valued _ TRUE; bound[i].value _ val; ENDLOOP; RETURN; }; IF actuals.named THEN BEGIN IF NOT bound.named THEN ERROR MatchError["No keywords to match against"]; FOR i: NAT IN [0 .. actuals.length) DO j: NAT _ FindName[bound, actuals[i].name]; IF j >= bound.length THEN BEGIN SIGNAL MatchWarning["%g is not a valid key for %g", IO.rope[actuals[i].name], IO.rope[lname]]; LOOP; END; IF bound[j].valued THEN SIGNAL MatchWarning["%g was bound multiple times", IO.rope[Describe[j]]]; IF actuals[i].valued THEN SetValue[j, i] ELSE Miss[j, elide]; ENDLOOP; END ELSE BEGIN IF actuals.length > formals.length THEN SIGNAL MatchWarning["%g extra fields for %g ignored", IO.int[actuals.length - formals.length], IO.rope[lname]]; FOR i: NAT IN [0 .. MIN[formals.length, actuals.length]) DO IF actuals[i].valued THEN SetValue[i, i] ELSE Miss[i, elide]; ENDLOOP; END; FOR i: NAT IN [0 .. bound.length) DO IF NOT bound[i].valued THEN Miss[i, omit]; ENDLOOP; END; FindName: PROC [fields: Fields, name: ROPE] RETURNS [index: NAT] = BEGIN FOR index _ 0, index + 1 WHILE index < fields.length DO IF name.Equal[fields[index].name] THEN RETURN; ENDLOOP; END; UnvalueFields: PROC [from: Fields] RETURNS [to: Fields] = BEGIN to _ NEW [FieldsRep[from.length]]; to.named _ from.named; FOR i: NAT IN [0 .. to.length) DO to[i] _ from[i]; to[i].valued _ FALSE ENDLOOP; END; Bind: PROC [st: SymbolTable, fields: Fields] = BEGIN FOR i: NAT IN [0 .. fields.length) DO IF fields[i].name = NIL THEN LOOP; IF fields[i].valued THEN BEGIN [] _ SymTab.Store[st, fields[i].name, AMTypes.Copy[fields[i].value]]; END ELSE IF fields[i].typed THEN BEGIN [] _ SymTab.Store[st, fields[i].name, AMTypes.New[fields[i].type]]; END; ENDLOOP; END; Start: PROC = { emptyFields.named _ FALSE; }; Start[]; END.