(define assoc (lambda (key alist) (if (null? alist) #f (if (eq? (car (car alist)) key) (car alist) (assoc key (cdr alist)))))) (define lookup (lambda (var env) ((lambda (val) (if val (car (cdr val)) (lookup var (cdr env)))) (assoc var (car env))))) (define add-defn! (lambda (var val env) (set-car! env (cons (cons var (cons val (quote ()))) (car env))) (quote ok))) (define make-frame (lambda (vars vals) (if (null? vars) (quote ()) (cons (cons (car vars) (cons (car vals) (quote ()))) (make-frame (cdr vars) (cdr vals)))))) (define make-function (lambda (args body env) (cons (quote function) (cons args (cons body (cons env (quote ()))))))) (define function? (lambda (sexpr) (if (pair? sexpr) (eq? (car sexpr) (quote function)) (procedure? sexpr)))) (define self-evaluating? (lambda (sexpr) (if (number? sexpr) #t (if (boolean? sexpr) #t (if (function? sexpr) #t (string? sexpr)))))) (define meta-eval (lambda (sexpr env) (if (self-evaluating? sexpr) sexpr (if (symbol? sexpr) (lookup sexpr env) ((lambda (first) (if (eq? first (quote quote)) (car (cdr sexpr)) (if (eq? first (quote define)) (add-defn! (car (cdr sexpr)) (meta-eval (car (cdr (cdr sexpr))) env) env) (if (eq? first (quote if)) (if (meta-eval (car (cdr sexpr)) env) (meta-eval (car (cdr (cdr sexpr))) env) (meta-eval (car (cdr (cdr (cdr sexpr)))) env)) (if (eq? first (quote lambda)) (make-function (car (cdr sexpr)) (cdr (cdr sexpr)) env) (if (eq? first (quote begin)) (meta-eval-list-return-last (cdr sexpr) env) (meta-apply (meta-eval (car sexpr) env) (meta-eval-list (cdr sexpr) env)))))))) (car sexpr)))))) (define meta-apply (lambda (func vals) (if (procedure? func) (apply func vals) (meta-eval-list-return-last (car (cdr (cdr func))) (cons (make-frame (car (cdr func)) vals) (car (cdr (cdr (cdr func))))))))) (define meta-eval-list (lambda (ls env) (if (null? ls) (quote ()) (cons (meta-eval (car ls) env) (meta-eval-list (cdr ls) env))))) (define meta-eval-list-return-last (lambda (ls env) (if (null? (cdr ls)) (meta-eval (car ls) env) (begin (meta-eval (car ls) env) (meta-eval-list-return-last (cdr ls) env))))) (define done? (lambda (sexpr) (if (pair? sexpr) (eq? (car sexpr) (quote exit)) #f))) (define scheme-main-loop (lambda (depth env) (display depth) (display "> ") ((lambda (input) (if (done? input) (quote done) ((lambda () (write (meta-eval input env)) (newline) (scheme-main-loop depth env))))) (read)))) (define scheme (lambda (depth) (display "Welcome to Meta-circular Scheme!") (newline) (scheme-main-loop depth global-env))) (define global-env (cons (cons (cons (quote car) (cons car (quote ()))) (cons (cons (quote cdr) (cons cdr (quote ()))) (cons (cons (quote cons) (cons cons (quote ()))) (cons (cons (quote set-car!) (cons set-car! (quote ()))) (cons (cons (quote null?) (cons null? (quote ()))) (cons (cons (quote eq?) (cons eq? (quote ()))) (cons (cons (quote +) (cons + (quote ()))) (cons (cons (quote -) (cons - (quote ()))) (cons (cons (quote *) (cons * (quote ()))) (cons (cons (quote /) (cons / (quote ()))) (cons (cons (quote >) (cons > (quote ()))) (cons (cons (quote apply) (cons apply (quote ()))) (cons (cons (quote number?) (cons number? (quote ()))) (cons (cons (quote boolean?) (cons boolean? (quote ()))) (cons (cons (quote string?) (cons string? (quote ()))) (cons (cons (quote symbol?) (cons symbol? (quote ()))) (cons (cons (quote procedure?) (cons procedure? (quote ()))) (cons (cons (quote pair?) (cons pair? (quote ()))) (cons (cons (quote read) (cons read (quote ()))) (cons (cons (quote write) (cons write (quote ()))) (cons (cons (quote display) (cons display (quote ()))) (cons (cons (quote newline) (cons newline (quote ()))) (quote ()))))))))))))))))))))))) (quote ())))