//PureLisp import gi.*; class PureLisp extends SLR1_Grammar { //PureLisp.Pair /*\semantics*/ class Pair { Object car; Object cdr; Pair(Object car, Object cdr) { this.car = car; this.cdr = cdr; } public String toString() { return format(this); } //PureLisp.Pair }/*\off*/ //PureLisp.cons /*\semantics*/ Object cons(Object e1, Object e2) { return new Pair(e1, e2); } Object car(Object e) throws Exception { if (!(e instanceof Pair)) throw new Exception( "car operation undefined"); return ((Pair)e).car; } Object cdr(Object e) throws Exception { if (!(e instanceof Pair)) throw new Exception( "cdr operation undefined"); return ((Pair)e).cdr; } Object cadr(Object e) throws Exception {return car(cdr(e));} Object caddr(Object e) throws Exception {return car(cdr(cdr(e)));} Object caar(Object e) throws Exception {return car(car(e));} Object cadar(Object e) throws Exception {return car(cdr(car(e)));} Object caddar(Object e) throws Exception {return car(cdr(cdr(car(e))));}/*\off*/ //PureLisp.eq /*\semantics*/ boolean eq(Object e1, Object e2) throws Exception { if (e1 == null && e2 == null) return true; else if (e1 instanceof String && e2 instanceof String) return e1.equals(e2); else if (e1 instanceof Pair && e2 instanceof Pair) return eq(car(e1), car(e2)) && eq(cdr(e1), cdr(e2)); else return false; }/*\off*/ //PureLisp.condval /*\semantics*/ Object condval(Object cases, Object env) throws Exception { if (cases == null) throw new Exception( "cond operation undefined"); if (eval(caar(cases), env) != null) return eval(cadar(cases), env); else return condval(cdr(cases), env); }/*\off*/ //PureLisp.atomval /*\semantics*/ Object atomval(Object identifier, Object env) throws Exception { if (env == null) throw new Exception( identifier + " undefined"); if (eq(identifier, caar(env))) return cdr(car(env)); else return atomval(identifier, cdr(env)); }/*\off*/ //PureLisp.bind /*\semantics*/ Object bind(Object formals, Object exprs, Object env) throws Exception { if (formals == null && exprs == null) return env; else return cons(cons(car(formals), eval(car(exprs), env)), bind(cdr(formals), cdr(exprs), env)); }/*\off*/ //PureLisp.eval /*\semantics*/ Object eval(Object e, Object env) throws Exception { if (e == null) return e; else if (e instanceof String) return (e.equals("T")) ? e : atomval(e, env); else if (car(e) instanceof String) if (car(e).equals("quote")) return cadr(e); else if (car(e).equals("car")) return car(eval(cadr(e), env)); else if (car(e).equals("cdr")) return cdr(eval(cadr(e), env)); else if (car(e).equals("cons")) return cons(eval(cadr(e), env), eval(caddr(e), env)); else if (car(e).equals("atom")) return (eval(cadr(e), env) instanceof String) ? "T" : null; else if (car(e).equals("eq")) return (eq(eval(cadr(e), env), eval(caddr(e), env))) ? "T" : null; else if (car(e).equals("cond")) return condval(cdr(e), env); else return eval(cons(atomval(car(e), env), cdr(e)), env); else if (caar(e) instanceof String) if (caar(e).equals("lambda")) return eval(caddar(e), bind(cadar(e), cdr(e), env)); else if (caar(e).equals("label")) return eval(cons(caddar(e), cdr(e)), cons(cons(cadar(e), caddar(e)), env)); else throw new Exception( "eval operation undefined"); else throw new Exception( "eval operation undefined"); }/*\off*/ String formatCdr(Object e) { if (e == null) return ""; else if (e instanceof String) return "." + e; else return " " + format(((Pair)e).car) + formatCdr(((Pair)e).cdr); } String format(Object e) { if (e == null) return "NIL"; else if (e instanceof String) return (String)e; else return "(" + format(((Pair)e).car) + formatCdr(((Pair)e).cdr) + ")"; } //PureLisp PureLisp() throws Exception { put("IDENTIFIER", expression("[[:alnum:]]+")); put("SPACE", expression("[[:space:]]+")); put("T", expression("T|t")); put("NIL", expression("NIL|nil")); // /*\semantics*/semantic specification/*\off*/ //PureLisp.Program /*\semantics*/ Semantics interpret = new Semantics() { public void f(ParseTree t, int l) throws Exception { t.value = eval(t.child[l-1].value, null); System.out.println(format(t.value)); } }; /*\off*/ put("Program", new Object[][] { {"Expr"/*\semantics*/, interpret/*\off*/} }); //PureLisp.Expr /*\semantics*/ Semantics identity = new Semantics() { public void f(ParseTree t, int l) { t.value = t.child[l-1].value; } }; /*\off*/ put("Expr", new Object[][] { {"Atom"/*\semantics*/, identity/*\off*/}, {"List"/*\semantics*/, identity/*\off*/}, }); //PureLisp.Atom /*\semantics*/ Semantics truth = new Semantics() { public void f(ParseTree t, int l) { t.value = "T"; } }; /*\off*/ put("Atom", new Object[][] { {"T"/*\semantics*/, truth/*\off*/}, {"IDENTIFIER"/*\semantics*/, identity/*\off*/}, }); //PureLisp.List.NIL /*\semantics*/ Semantics list_zero = new Semantics() { public void f(ParseTree t, int l) { t.value = null; } }; /*\off*/ put("List", new Object[][] { {"NIL"/*\semantics*/, list_zero/*\off*/}, }); //PureLisp.List.Exprs /*\semantics*/ Semantics list_one_plus = new Semantics() { public void f(ParseTree t, int l) { t.value = cons(t.child[l-2].value, t.child[l-1].value); } }; /*\off*/ put("List", new Object[][] { {"(", "Exprs", /*\semantics*/identity, /*\off*/")"}, }); put("Exprs", new Object[][] { {/*\semantics*/list_zero/*\off*/}, {"Expr", "Exprs"/*\semantics*/, list_one_plus/*\off*/}, }); //PureLisp.List.quote /*\semantics*/ Semantics list_two = new Semantics() { public void f(ParseTree t, int l) { t.value = cons(t.child[l-2].value, cons(t.child[l-1].value, null)); } }; /*\off*/ put("List", new Object[][] { {"(", "quote", "Expr", /*\semantics*/list_two, /*\off*/")"}, {"(", "car", "Expr", /*\semantics*/list_two, /*\off*/")"}, {"(", "cdr", "Expr", /*\semantics*/list_two, /*\off*/")"}, {"(", "atom", "Expr", /*\semantics*/list_two, /*\off*/")"}, }); //PureLisp.List.cons /*\semantics*/ Semantics list_three = new Semantics() { public void f(ParseTree t, int l) { t.value = cons(t.child[l-3].value, cons(t.child[l-2].value, cons(t.child[l-1].value, null))); } }; /*\off*/ put("List", new Object[][] { {"(", "cons", "Expr", "Expr", /*\semantics*/list_three, /*\off*/")"}, {"(", "eq", "Expr", "Expr", /*\semantics*/list_three, /*\off*/")"}, }); //PureLisp.List.cond put("List", new Object[][] { {"(", "cond", "Cases", /*\semantics*/list_one_plus, /*\off*/")"}, }); put("Cases", new Object[][] { {/*\semantics*/list_zero/*\off*/}, {"Case", "Cases"/*\semantics*/, list_one_plus/*\off*/}, }); put("Case", new Object[][] { {"(", "Expr", "Expr", /*\semantics*/list_two, /*\off*/")"} }); //PureLisp.List.AnonFunc /*\semantics*/ Semantics list_three_of_five = new Semantics() { public void f(ParseTree t, int l) { t.value = cons(t.child[l-5].value, cons(t.child[l-3].value, cons(t.child[l-1].value, null))); } }; /*\off*/ put("List", new Object[][] { {"(", "AnonFunc", "Exprs", /*\semantics*/list_one_plus, /*\off*/")"}, }); put("AnonFunc", new Object[][] { {"(", "lambda", "(", "Formals", ")", "Expr", /*\semantics*/list_three_of_five, /*\off*/")"} }); put("Formals", new Object[][] { {/*\semantics*/list_zero/*\off*/}, {"IDENTIFIER", "Formals"/*\semantics*/, list_one_plus/*\off*/}, }); //PureLisp.List.NamedFunc put("List", new Object[][] { {"(", "NamedFunc", "Exprs", /*\semantics*/list_one_plus, /*\off*/")"}, }); put("NamedFunc", new Object[][] { {"(", "label", "IDENTIFIER", "AnonFunc", /*\semantics*/list_three, /*\off*/")"} }); } //PureLisp public static void main(String[] arguments) throws Exception { new PureLisp().interpret(arguments); } }