<> <> <<>> DIRECTORY AMBridge, AMTypes, Commander, EvalQuote, InterpreterOps, IO, List, PPTree, PPTreeOps, PrintTV, ProcessProps, Rope, SafeStorage, SymTab; StatementFunctions: CEDAR PROGRAM IMPORTS AMBridge, AMTypes, EvalQuote, InterpreterOps, IO, List, PPTreeOps, PrintTV, ProcessProps, Rope, SafeStorage, SymTab = BEGIN ROPE: TYPE = Rope.ROPE; TV: TYPE = AMTypes.TV; Type: TYPE = AMTypes.Type; SymbolTable: TYPE = SymTab.Ref; EvalHead: TYPE = InterpreterOps.EvalHead; Tree: TYPE = InterpreterOps.Tree; nullType: Type = AMTypes.nullType; GetStream: PROC RETURNS [IO.STREAM] = { WITH List.Assoc[$CommanderHandle, ProcessProps.GetPropList[]] SELECT FROM cmd: Commander.Handle => RETURN [cmd.out]; ENDCASE => RETURN [NIL]; }; empty: TV _ AMTypes.GetEmptyTV[]; Fields: TYPE = REF FieldsRep; FieldsRep: TYPE = RECORD [ named: BOOLEAN, fields: SEQUENCE length: CARDINAL OF Field]; Field: TYPE = RECORD [ name: ROPE _ NIL, type: AMTypes.Type _ nullType, typed, valued: BOOLEAN _ FALSE, value: REF ANY _ NIL]; typeType: Type; typeAsTV: TV; typeAsType: REF Type; MyTreeToType: PROC [tree: Tree, head: EvalHead] RETURNS [type: Type] = BEGIN asTV: TV; itsType: Type; asTV _ InterpreterOps.Eval[tree, head]; IF SafeStorage.EquivalentTypes[typeType, AMTypes.TVType[asTV]] THEN BEGIN AMTypes.Assign[typeAsTV, asTV]; RETURN[typeAsType^]; END; itsType _ AMTypes.TVType[asTV]; SELECT AMTypes.TypeClass[AMTypes.UnderType[itsType]] FROM type => RETURN[AMTypes.TVToType[asTV]]; ENDCASE => BEGIN head.helpFatalClosure.proc[data: head.helpFatalClosure.data, head: head, parent: tree, msg: "Not a TYPE"]; END; END; Mush: PROC [tv: TV] RETURNS [mushy: TV] = BEGIN <> <> IF AMTypes.TVStatus[tv] = mutable THEN RETURN[tv]; mushy _ AMTypes.Copy[tv]; <> <> < tag _ AMTypes.Tag[tv];>> <> <> <> END; DigestFields: PROC [tree: Tree, eval: 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; IF (fields[index].typed _ type # NIL) THEN fields[index].type _ MyTreeToType[type, head]; IF NOT (fields[index].valued _ value # NIL) THEN NULL ELSE IF NOT eval THEN fields[index].value _ value ELSE fields[index].value _ InterpreterOps.Eval[value, head]; index _ index + 1; END; ENDCASE => ERROR; END; IF name = NIL THEN RealWork[NIL] ELSE PPTreeOps.ScanList[name, RealWork]; END; 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; 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; CopyFields: 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] ENDLOOP; 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; Match: PROC [formals, actuals: Fields, lname: ROPE] RETURNS [bound: Fields] = BEGIN 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's %g'th arg", IO.rope[lname], IO.card[i]]]}; bound _ CopyFields[formals]; IF bound.length < 1 THEN RETURN; IF actuals.named THEN BEGIN bindCount: NAT _ 0; 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", IO.rope[actuals[i].name]]; LOOP; END; IF actuals[i].valued THEN BEGIN SetValue[j, i]; bindCount _ bindCount + 1; END; ENDLOOP; IF bindCount > bound.length THEN SIGNAL MatchWarning["Some keys were bound to multiple times"]; END ELSE BEGIN IF actuals.length > formals.length THEN SIGNAL MatchWarning["%g extra arguments ignored", IO.int[actuals.length - formals.length]]; FOR i: NAT IN [0 .. MIN[formals.length, actuals.length]) DO IF actuals[i].valued THEN SetValue[i, i]; ENDLOOP; END; FOR i: NAT IN [0 .. bound.length) DO IF NOT bound[i].valued THEN BEGIN IF bound.named THEN ERROR MatchError["%g unbound", IO.rope[Describe[i]]] ELSE ERROR MatchError["%g unbound", IO.rope[Describe[i]]]; END; ENDLOOP; END; SafeMatch: PROC [formals, actuals: Fields, lname: ROPE, head: EvalHead, parent: Tree] RETURNS [bound: Fields] = BEGIN bound _ Match[formals, actuals, lname ! MatchWarning => {GetStream[].PutF[Rope.Cat["Warning: ", fmt, "\n"], v1, v2, v3, v4]; RESUME}; MatchError => {head.helpFatalClosure.proc[data: head.helpFatalClosure.data, head: head, parent: parent, msg: IO.PutFR[format, v1, v2, v3, v4]]; CONTINUE}]; END; defineFields: Fields _ NEW[FieldsRep[3]]; EvalDefine: PROC [head: EvalHead, tree: Tree, target: Type _ nullType, data: REF _ NIL] RETURNS [return: TV] --EvalQuote.EvalQuoteProc-- = BEGIN myArgs, name, type, procArgs, procRets, expr: Tree; myFields: Fields; l: Lambda _ NEW[LambdaRep _ []]; IF PPTreeOps.OpName[tree] # apply THEN ERROR; myArgs _ PPTreeOps.NthSon[tree, 2]; myFields _ SafeMatch[defineFields, DigestFields[myArgs, FALSE], "define", head, tree]; name _ myFields[0].value; type _ myFields[1].value; expr _ myFields[2].value; IF PPTreeOps.OpName[name] # none THEN BEGIN GetStream[].PutF["Define.name should be an ID, not %g\n", IO.refAny[name]]; RETURN[empty]; END; IF PPTreeOps.OpName[type] # typecode THEN BEGIN GetStream[].PutF["Define.type should be CODE[a PROCEDURE TYPE-constructor], not %g\n", IO.refAny[type]]; RETURN[empty]; END; type _ PPTreeOps.NthSon[type, 1]; IF PPTreeOps.OpName[type] # procTC THEN BEGIN GetStream[].PutF["Define.type should be CODE[a PROCEDURE TYPE-constructor], not %g\n", IO.refAny[type]]; RETURN[empty]; END; procArgs _ PPTreeOps.NthSon[type, 1]; procRets _ PPTreeOps.NthSon[type, 2]; l.name _ InterpreterOps.TreeToName[name]; l.args _ DigestFields[procArgs, TRUE, head]; l.rets _ DigestFields[procRets, TRUE, head]; IF l.rets.length > 1 THEN BEGIN GetStream[].PutF["Can't handle %g return values, only 0 or 1.\n", IO.card[l.rets.length]]; RETURN[empty]; END; l.expr _ expr; l.symbols _ head.specials; EvalQuote.Register[l.name, EvalProcedure, head.specials, l]; return _ empty; END; Lambda: TYPE = REF LambdaRep; LambdaRep: TYPE = RECORD [ name: ROPE _ NIL, args, rets: Fields _ NIL, expr: Tree _ NIL, symbols: SymbolTable _ NIL]; NestHead: PROC [outer: EvalHead] RETURNS [inner: EvalHead] = BEGIN found: BOOL; sttv, sttv2: TV; inner _ NEW [InterpreterOps.EvalHeadRep _ outer^]; inner.specials _ CopySymbolTable[outer.specials]; [found, sttv] _ inner.specials.Fetch["&EvalQuoteSymTab"]; IF found THEN { eqst, eqst2: SymbolTable; TRUSTED {eqst _ LOOPHOLE[AMBridge.RefFromTV[sttv]]}; eqst2 _ CopySymbolTable[eqst]; TRUSTED {sttv2 _ AMBridge.TVForReferent[eqst2]}; [] _ inner.specials.Store["&EvalQuoteSymTab", sttv2]}; END; EvalProcedure: PROC [head: EvalHead, tree: Tree, target: Type _ nullType, data: REF _ NIL] RETURNS [return: TV] --EvalQuote.EvalQuoteProc-- = BEGIN args: Tree; actualFields, match, 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, head]; match _ SafeMatch[l.args, actualFields, l.name, head, tree]; subHead _ NestHead[head]; Bind[subHead.specials, match]; Bind[subHead.specials, l.rets]; [] _ InterpreterOps.Eval[l.expr, subHead ! Return => {ans _ fields; CONTINUE}]; IF ans = NIL THEN ans _ emptyFields; IF l.rets.length = 0 THEN BEGIN IF ans.length # 0 THEN GetStream[].PutF["Warning: values returned to %g, who wasn't expecting them\n", IO.rope[l.name]]; return _ empty; END ELSE BEGIN IF ans.length = 0 THEN BEGIN IF l.rets.named THEN BEGIN found: BOOLEAN; [found, return] _ subHead.specials.Fetch[l.rets[0].name]; IF NOT found THEN BEGIN GetStream[].PutF["Error: return value %g undefined\n", IO.rope[l.rets[0].name]]; return _ empty; END; END ELSE BEGIN GetStream[].PutF["Error: default return of anonymous value\n"]; return _ empty; END; END ELSE BEGIN return _ ans[0].value; END; IF return # empty AND l.rets[0].typed THEN BEGIN return _ AMTypes.Coerce[return, l.rets[0].type !AMTypes.Error => BEGIN s: IO.STREAM _ GetStream[]; s.PutF["Type mismatch on return from %g: expected ", IO.rope[l.name]]; PrintTV.PrintType[l.rets[0].type, s]; s.PutRope[", got "]; PrintTV.Print[return, s]; s.PutChar['\n]; END]; END; END; END; OldBind: PROC [st: SymbolTable, fields: Fields, createShadows: BOOLEAN] RETURNS [shadows: Fields] = BEGIN IF createShadows THEN shadows _ CopyFields[fields]; FOR i: NAT IN [0 .. fields.length) DO IF fields[i].name = NIL THEN LOOP; IF fields[i].valued THEN BEGIN IF createShadows THEN [shadows[i].valued, shadows[i].value] _ st.Fetch[fields[i].name]; [] _ st.Store[fields[i].name, fields[i].value]; END ELSE IF createShadows THEN shadows[i].valued _ FALSE; ENDLOOP; END; CopySymbolTable: PROC [old: SymbolTable] RETURNS [new: SymbolTable] = BEGIN ToNew: SymTab.EachPairAction --PROC [key: Key, val: Val] RETURNS [quit: BOOL]-- = {[] _ new.Store[key, val]; quit _ FALSE}; new _ SymTab.Create[]; [] _ old.Pairs[ToNew]; 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 [] _ st.Store[fields[i].name, AMTypes.Copy[fields[i].value]]; END ELSE IF fields[i].typed THEN BEGIN [] _ st.Store[fields[i].name, AMTypes.New[fields[i].type]]; END; ENDLOOP; END; Return: SIGNAL [fields: Fields] = CODE; emptyFields: Fields _ NEW[FieldsRep[0]]; EvalReturn: PROC [head: EvalHead, tree: Tree, target: Type _ nullType, data: REF _ NIL] RETURNS [return: TV] --EvalQuote.EvalQuoteProc-- = BEGIN args: Tree; fields: Fields; IF PPTreeOps.OpName[tree] # apply THEN ERROR; args _ PPTreeOps.NthSon[tree, 2]; fields _ DigestFields[args, TRUE, head]; SIGNAL Return[fields]; return _ empty; END; EvalLetProgN: PROC [head: EvalHead, tree: Tree, target: Type _ nullType, data: REF _ NIL] RETURNS [return: TV] --EvalQuote.EvalQuoteProc-- = BEGIN first: BOOLEAN _ TRUE; DoIt: PPTree.Scan --PROC [t: Link]-- = BEGIN IF first THEN BEGIN first _ FALSE; IF PPTreeOps.OpName[t] = typecode THEN BEGIN rc: Tree _ PPTreeOps.NthSon[t, 1]; IF PPTreeOps.OpName[rc] = recordTC THEN BEGIN fields: Fields _ DigestFields[PPTreeOps.NthSon[rc, 1], TRUE, head]; head _ NestHead[head]; Bind[head.specials, fields]; RETURN; END; END; END; return _ InterpreterOps.Eval[t, head]; END; return _ empty; PPTreeOps.ScanList[PPTreeOps.NthSon[tree, 2], DoIt]; END; cforFields: Fields _ NEW[FieldsRep[4]]; Exit: ERROR [value: TV _ NIL] = CODE; Loop: ERROR [value: TV _ NIL] = CODE; EvalCFor: PROC [head: EvalHead, tree: Tree, target: Type _ nullType, data: REF _ NIL] RETURNS [return: TV] --EvalQuote.EvalQuoteProc-- = BEGIN special: BOOLEAN _ FALSE; rawArgFields: Fields _ DigestFields[PPTreeOps.NthSon[tree, 2], FALSE]; argFields: Fields _ SafeMatch[cforFields, rawArgFields, "cfor", head, tree]; init, test, step, body: Tree; init _ argFields[0].value; test _ argFields[1].value; step _ argFields[2].value; body _ argFields[3].value; return _ empty; IF PPTreeOps.OpName[init] = typecode THEN BEGIN rc: Tree _ PPTreeOps.NthSon[init, 1]; IF PPTreeOps.OpName[rc] = recordTC THEN BEGIN fields: Fields _ DigestFields[PPTreeOps.NthSon[rc, 1], TRUE, head]; head _ NestHead[head]; Bind[head.specials, fields]; special _ TRUE; END; END; IF NOT special THEN [] _ InterpreterOps.Eval[init, head]; DO testTV: TV _ InterpreterOps.Eval[test, head]; card: LONG CARDINAL; TRUSTED {card _ AMBridge.TVToLC[testTV]}; IF card = 0 THEN EXIT; return _ InterpreterOps.Eval[body, head !Exit => {return _ value; EXIT}; Loop => {return _ value; CONTINUE}]; [] _ InterpreterOps.Eval[step, head]; ENDLOOP; END; EvalExit: PROC [head: EvalHead, tree: Tree, target: Type _ nullType, data: REF _ NIL] RETURNS [return: TV] --EvalQuote.EvalQuoteProc-- = {ERROR Exit[EvalLetProgN[head: head, tree: tree]]}; EvalLoop: PROC [head: EvalHead, tree: Tree, target: Type _ nullType, data: REF _ NIL] RETURNS [return: TV] --EvalQuote.EvalQuoteProc-- = {ERROR Loop[EvalLetProgN[head: head, tree: tree]]}; EvalAbort: PROC [head: EvalHead, tree: Tree, target: Type _ nullType, data: REF _ NIL] RETURNS [return: TV] --EvalQuote.EvalQuoteProc-- = {ERROR ABORTED}; EvalPrint: PROC [head: EvalHead, tree: Tree, target: Type _ nullType, data: REF _ NIL] RETURNS [return: TV] --EvalQuote.EvalQuoteProc-- = BEGIN PrintIt: PPTree.Scan --PROC [t: Link]-- = BEGIN tv: TV _ InterpreterOps.Eval[t, head]; IF first THEN first _ FALSE ELSE out.PutRope[", "]; PrintTV.Print[tv, out]; END; out: IO.STREAM _ GetStream[]; first: BOOLEAN _ TRUE; return _ empty; PPTreeOps.ScanList[PPTreeOps.NthSon[tree, 2], PrintIt]; IF NOT first THEN out.PutChar['\n]; END; Setup: PROC = BEGIN TRUSTED {typeAsTV _ AMBridge.TVForReferent[typeAsType _ NEW[Type]]}; typeType _ AMTypes.TVType[typeAsTV]; defineFields.named _ TRUE; defineFields[0] _ ["name", nullType, FALSE, FALSE, NIL]; defineFields[1] _ ["type", nullType, FALSE, FALSE, NIL]; defineFields[2] _ ["expr", nullType, FALSE, FALSE, NIL]; cforFields.named _ TRUE; cforFields[0] _ ["init", nullType, FALSE, FALSE, NIL]; cforFields[1] _ ["test", nullType, FALSE, FALSE, NIL]; cforFields[2] _ ["step", nullType, FALSE, FALSE, NIL]; cforFields[3] _ ["body", nullType, FALSE, FALSE, NIL]; EvalQuote.Register["&define", EvalDefine, NIL]; EvalQuote.Register["&return", EvalReturn, NIL]; EvalQuote.Register["&block", EvalLetProgN, NIL]; EvalQuote.Register["&cfor", EvalCFor, NIL]; EvalQuote.Register["&exit", EvalExit, NIL]; EvalQuote.Register["&loop", EvalLoop, NIL]; EvalQuote.Register["&print", EvalPrint, NIL]; EvalQuote.Register["&abort", EvalAbort, NIL]; END; Setup[]; END. <<>> <<&define[name: id, type: CODE[procTC], expr: expr]>> <<>> <> <<>> <<&return[expr]>> <<>> <> <<>> <<&block[expr1, expr2, ... exprN]>> <<>> <> <<>> <<&block[CODE[recordTC], expr1, expr2, ... exprN]>> <<>> <> <<>> <<&cfor[init: expr, test: booleanExpr, step: expr, body: expr]>> <<>> <> <> <> <> <<>> <<&loop[expr1, expr2, ... exprN]>> <<&loop[CODE[recordTC], expr1, expr2, ... exprN]>> <<>> <> <<>> <<&exit[expr1, expr2, ... exprN]>> <<&exit[CODE[recordTC], expr1, expr2, ... exprN]>> <<>> <> <<>> <<&print[expr1, expr2, ... exprN]>> <<>> <> <<>> <<&abort[]>> <<>> <> <<>>