meta-circular-interpreter.scm

(define (%built-in-object name)
  (let ((p (eval name)))
    (if (procedure? p)
      (lambda (vars) (lambda (cont) (cont `(,(apply p vars)))))
      p)))

(define %primitive-environment '())
(define (%update-primitive-environment! binding)
  (set! %primitive-environment `(,binding . ,%primitive-environment)))
(define (%get-binding var env)
  (or (assq var env) (assq var %primitive-environment)))

(define (%new-env 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 var env)
  (lambda (cont)
    (let ((binding (%get-binding var env)))
      (if binding
        (cont `(,(cdr binding)))
        (let ((val (%built-in-object var)))
          (%update-primitive-environment! `(,var . ,val))
          (cont `(,val)))))))

(define (%assign binding val)
  (lambda (cont)
    (val (lambda (val) (set-cdr! binding (car val)) (cont '())))))

(define (%analyze expr env)
  (define (analyze-quasiquoted expr nest-level)
    (define (analyze-interesting-list lis)
      (lambda (cont)
        (case (car lis)
          ((quasiquote)
           ((analyze-quasiquoted (cadr lis) (+ nest-level 1))
            (lambda (val) (cont `(((quasiquote . ,val)))))))
          ((unquote)
           (if (= nest-level 0)
             ((%analyze (cadr lis) env) (lambda (val) (cont `(,val))))
             ((analyze-quasiquoted (cadr lis) (- nest-level 1))
              (lambda (val) (cont `(((unquote . ,val))))))))
          ((unquote-splicing)
           (if (= nest-level 0)
             ((%analyze (cadr lis) env) cont)
             ((analyze-quasiquoted (cadr lis) (- nest-level 1))
              (lambda (val) (cont `(((unquote-splicing . ,val))))))))
          (else
           ((analyze-quasiquoted (cadr lis) nest-level)
            (lambda (val) (cont `(((,(car lis) . ,val))))))))))

    (if (vector? expr)
      (lambda (cont)
        ((analyze-quasiquoted (vector->list expr) nest-level)
         (lambda (val) (cont `(,(list->vector (car val)))))))
      (lambda (cont)
        (let recur ((expr expr) (cont cont))
          (if (pair? expr)
            (let ((prtl-expr (car expr)))
              (cond
                ((and (symbol? prtl-expr) (pair? (cdr expr)) (null? (cddr expr)))
                 ((analyze-interesting-list expr)
                  (lambda (val) (cont (car val)))))
                ((pair? prtl-expr)
                 (if (and (symbol? (car prtl-expr))
                          (pair? (cdr prtl-expr)) (null? (cddr prtl-expr)))
                   ((analyze-interesting-list prtl-expr)
                    (if (null? (cdr expr))
                      cont
                      (lambda (val)
                        (recur (cdr expr)
                               (lambda (tail)
                                 (cont `((,@(car val) . ,(car tail)))))))))
                   ((analyze-quasiquoted prtl-expr nest-level)
                    (lambda (val)
                      (recur (cdr expr)
                             (lambda (tail)
                               (cont `((,(car val) . ,(car tail))))))))))
                (else
                 (recur (cdr expr)
                        (lambda (tail) (cont `((,prtl-expr . ,(car tail)))))))))
            (cont `(,expr)))))))

  (cond
    ((symbol? expr) (%lookup expr env))
    ((pair? expr)
     (case (car expr)
       ((quote) (lambda (cont) (cont (cdr expr))))
       ((quasiquote) (analyze-quasiquoted (cadr expr) 0))
       ((lambda)
        (lambda (cont)
          (define (definition? expr) (and (pair? expr) (eq? (car expr) 'define)))
          (let lp ((body (cddr expr)) (non-def? #f))
            (if (pair? body)
              (if (definition? (car body))
                (if (or non-def? (null? (cdr body)))
                  'definition-at-wrong-position-error
                  (lp (cdr body) #f))
                (lp (cdr body) #t))

              (cont `(,(lambda (vals)
                         (do ((env (%new-env (cadr expr) vals env)
                                   `((,(cadar maybe-defs)) . ,env))
                              (maybe-defs (cddr expr) (cdr maybe-defs)))
                             ((not (definition? (car maybe-defs)))
                              (do ((body (cdddr expr) (cdr body))
                                   (seq (%analyze (caddr expr) env)
                                        (lambda (cont)
                                          (seq
                                           (lambda (_)
                                             ((%analyze (car body) env) cont))))))
                                  ((null? body) seq)))))))))))
       ((if)
        (lambda (cont)
          ((%analyze (cadr expr) env)
           (lambda (pred-val)
             (if (car pred-val)
               ((%analyze (caddr expr) env) cont)
               (if (null? (cddr expr))
                 (cont '())
                 ((%analyze (cadddr expr) env) cont)))))))
       ((set!)
        (%assign (%get-binding (cadr expr) env) (%analyze (caddr expr) env)))
       ((define)
        (let ((binding (%get-binding (cadr expr) env)))
          (or binding
              (begin (set! binding `(,(cadr expr)))
                     (%update-primitive-environment! binding)))
          (%assign binding (%analyze (caddr expr) env))))
       (else
        (lambda (cont)
          (let lp ((application (reverse expr)) (elts '()))
            (if (null? application)
              (((car elts) (cdr elts)) cont)
              ((%analyze (car application) env)
               (lambda (elt) (lp (cdr application) `(,(car elt) . ,elts))))))))))
    (else (lambda (cont) (cont `(,expr))))))

(define (interpret expr)
  (define (expand-definition expr)
    (if (and (eq? (car expr) 'define) (pair? (cadr expr)))
      `(define ,(caadr expr) (lambda ,(cdadr expr) . ,(cddr expr)))
      expr))

  (define (expand expr)
    (if (pair? expr)
      (let ((expr (expand-definition expr)))
        `(,(expand (car expr)) . ,(expand (cdr expr))))
      expr))

  ((%analyze (expand expr) '()) (lambda (ret) (apply values ret))))

; 特殊な定義が必要なプリミティブプロシージャ

(%update-primitive-environment!
 `(call-with-current-continuation
   . ,(lambda (f)
        (lambda (cont)
          (((car f) `(,(lambda (x) (lambda (_) (cont x))))) cont)))))

(%update-primitive-environment!
 `(call/cc
   . ,(cdr (assq 'call-with-current-continuation %primitive-environment))))

(%update-primitive-environment!
 `(apply
   . ,(lambda (application)
        (let* ((proc (car application))
               (rev-args (reverse (cdr application)))
               (args-init (reverse (cdr rev-args)))
               (args-last (car rev-args)))
          (proc `(,@args-init . ,args-last))))))

(%update-primitive-environment!
 `(values . ,(lambda (vals) (lambda (cont) (cont vals)))))

(%update-primitive-environment!
 `(call-with-values
   . ,(lambda (p&c)
        (lambda (cont)
          (((car p&c) '()) (lambda (vals) (((cadr p&c) vals) cont)))))))