meta-circular-interpreter.scm

(define primitive-environment
  `((apply . ,apply) (assq . ,assq)
    (call/cc . ,(lambda (f) (lambda (cont) ((f cont) cont))))
    (car . ,car) (cadr . ,cadr) (caddr . ,caddr)
    (display . ,(lambda (x) (lambda (cont) (cont (display x)))))
    (newline . ,(lambda () (lambda (cont) (cont (newline)))))
    (* . ,(lambda xs (lambda (cont) (cont (apply * xs)))))
    (cadddr . ,cadddr) (cddr . ,cddr) (cdr . ,cdr)
    (cons . ,(lambda (a d) (lambda (cont) (cont (cons a d)))))
    (eq? . ,eq?) (list . ,(lambda es (lambda (cont) (cont es)))) (map . ,map)
    (memv . ,memv) (null? . ,null?) (pair? . ,pair?)
    (read . ,read) (set-car! . ,set-car!)
    (set-cdr! . ,set-cdr!) (symbol? . ,symbol?)))

(define new-env
  (lambda (formals actuals env)
    (cond
      ((null? formals) env)
      ((symbol? formals) (cons (cons formals actuals) env))
      (else
       (cons
         (cons (car formals) (car actuals))
         (new-env (cdr formals) (cdr actuals) env))))))

(define lookup
  (lambda (var env)
    (let ((val (cdr (assq var env))))
      (lambda (cont) (cont val)))))

(define assign
  (lambda (var val env)
    (set-cdr! (assq var env) val)))

(define exec
  (lambda (expr env)
    (cond
      ((symbol? expr) (lookup expr env))
      ((pair? expr)
       (case (car expr)
         ((quote) (lambda (cont) (cont (cadr expr))))
         ((lambda)
          (lambda (cont)
            (cont (lambda vals
                    (let* ((env (new-env (cadr expr) vals env))
                           (pass-results
                            (map (lambda (prtl-expr) (exec prtl-expr env))
                                 (cddr expr))))
                      (let lp ((pass-results (cdr pass-results))
                               (seq (car pass-results)))
                        (if (null? pass-results)
                          seq
                          (lp (cdr pass-results)
                              (lambda (cont) 
                                (seq
                                 (lambda (_)
                                   ((car pass-results) cont))))))))))))
         ((if)
          (if (exec (cadr expr) env)
              (exec (caddr expr) env)
              (exec (cadddr expr) env)))
         ((set!) (assign (cadr expr) (exec (caddr expr) env) env))
         (else
          (let ((pass-elts
                 (map (lambda (prtl-expr) (exec prtl-expr env)) expr)))
            (lambda (cont)
              (let recur ((pass-elts pass-elts)
                          (cont
                           (lambda (elts) ((apply (car elts) (cdr elts)) cont))))
                (if (null? pass-elts)
                  (cont '())
                  ((car pass-elts)
                   (lambda (elt)
                     (recur (cdr pass-elts)
                            (lambda (elts) (cont `(,elt . ,elts)))))))))))))
      (else (lambda (cont) (cont expr))))))

(define interpret
  (lambda (expr)
    (call/cc (lambda (return)
      ((exec expr primitive-environment) return)))))