プログラミング言語 SCHEMEの練習問題9.7.1, 9.7.2 (メタ循環インタプリタ)

scheme-interpreter-interperter.scm

((lambda (interpret)
   ;; code
   (interpret '((lambda (interpret)
                  ;; code
                  (interpret '((lambda (a b) ((lambda (c d) (cons c d)) a b)) 1 2))
                  )
                ((lambda (primitive-environment new-env lookup assign)
                   ((lambda (exec)
                      (lambda (exp)
                        (exec exp primitive-environment)))
                    ;; exec
                    (lambda (exp env)
                      ((lambda (exec)
                         (exec exec exp env))
                       (lambda (exec exp env)
                         (if (symbol? exp)
                             (lookup exp env)
                             (if (pair? exp)
                                 (if (eq? (car exp) 'quote)
                                     (cadr exp)
                                     (if (eq? (car exp) 'lambda)
                                         (lambda vals
                                           ((lambda (env)
                                              ((lambda (loop exps)
                                                 (loop loop exps))
                                               (lambda (loop exps)
                                                 (if (null? (cdr exps))
                                                     (exec exec (car exps) env)
                                                     ((lambda ()
                                                        (exec exec (car exps) env)
                                                        (loop loop (cdr exps))))))
                                               (cddr exp))
                                              )
                                            (new-env (cadr exp) vals env)))
                                         (if (eq? (car exp) 'if)
                                             (if (exec exec (cadr exp) env)
                                                 (exec exec (caddr exp) env)
                                                 (exec exec  (cadddr exp) env))
                                             (if (eq? (car exp) 'set!)
                                                 (assign (cadr exp)
                                                         (exec exec (caddr exp) env)
                                                         env)
                                                 (apply (exec exec (car exp) env)
                                                        (map (lambda (x) (exec exec x env))
                                                             (cdr exp)))))))
                                 exp)))))
                    ))
                 ;; primitive-environment
                 (list (cons 'apply apply)
                       (cons 'assq assq)
                       (cons 'call/cc call/cc)
                       (cons 'car car)
                       (cons 'cadr cadr)
                       (cons 'caddr caddr)
                       (cons 'cadddr cadddr)
                       (cons 'cddr cddr)
                       (cons 'cdr cdr)
                       (cons 'cons cons)
                       (cons 'eq? eq?)
                       (cons 'list list)
                       (cons 'map map)
                       (cons 'memv memv)
                       (cons 'null? null?)
                       (cons 'pair? pair?)
                       (cons 'set-car! set-car!)
                       (cons 'set-cdr! set-cdr!)
                       (cons 'symbol? symbol?))
                 ;; new-env
                 (lambda (formals actuals env)
                   ((lambda (new-env)
                      (new-env new-env formals actuals env))
                    (lambda (new-env formals actuals env)
                      (if (null? formals)
                          env
                          (if (symbol? formals)
                              (cons (cons formals actuals) env)
                              (cons (cons (car formals) (car actuals))
                                    (new-env new-env (cdr formals) (cdr actuals) env)))))))
                 ;; lookup
                 (lambda (var env)
                   (cdr (assq var env)))
                 ;; assign
                 (lambda (var val env)
                   (set-cdr! (assq var env) val)))))
   )
 ((lambda (primitive-environment new-env lookup assign)
    ((lambda (exec)
       (lambda (exp)
         (exec exp primitive-environment)))
     ;; exec
     (lambda (exp env)
       ((lambda (exec)
          (exec exec exp env))
        (lambda (exec exp env)
          (if (symbol? exp)
              (lookup exp env)
              (if (pair? exp)
                  (if (eq? (car exp) 'quote)
                      (cadr exp)
                      (if (eq? (car exp) 'lambda)
                          (lambda vals
                            ((lambda (env)
                               ((lambda (loop exps)
                                  (loop loop exps))
                                (lambda (loop exps)
                                  (if (null? (cdr exps))
                                      (exec exec (car exps) env)
                                      ((lambda ()
                                         (exec exec (car exps) env)
                                         (loop loop (cdr exps))))))
                                (cddr exp))
                               )
                             (new-env (cadr exp) vals env)))
                          (if (eq? (car exp) 'if)
                              (if (exec exec (cadr exp) env)
                                  (exec exec (caddr exp) env)
                                  (exec exec  (cadddr exp) env))
                              (if (eq? (car exp) 'set!)
                                  (assign (cadr exp)
                                          (exec exec (caddr exp) env)
                                          env)
                                  (apply (exec exec (car exp) env)
                                         (map (lambda (x) (exec exec x env))
                                              (cdr exp)))))))
                  exp)))))
     ))
  ;; primitive-environment
  (list (cons 'apply apply)
        (cons 'assq assq)
        (cons 'call/cc call/cc)
        (cons 'car car)
        (cons 'cadr cadr)
        (cons 'caddr caddr)
        (cons 'cadddr cadddr)
        (cons 'cddr cddr)
        (cons 'cdr cdr)
        (cons 'cons cons)
        (cons 'eq? eq?)
        (cons 'list list)
        (cons 'map map)
        (cons 'memv memv)
        (cons 'null? null?)
        (cons 'pair? pair?)
        (cons 'set-car! set-car!)
        (cons 'set-cdr! set-cdr!)
        (cons 'symbol? symbol?))
  ;; new-env
  (lambda (formals actuals env)
    ((lambda (new-env)
       (new-env new-env formals actuals env))
     (lambda (new-env formals actuals env)
       (if (null? formals)
           env
           (if (symbol? formals)
               (cons (cons formals actuals) env)
               (cons (cons (car formals) (car actuals))
                     (new-env new-env (cdr formals) (cdr actuals) env)))))))
  ;; lookup
  (lambda (var env)
    (cdr (assq var env)))
  ;; assign
  (lambda (var val env)
    (set-cdr! (assq var env) val))))