SICP 4.2 Schemeの変形 - 遅延評価
"SICP 4.2 schemeの変形"を読んで遅延評価するインタプリタを書きました。
実装したインタプリタは前回の構文解析分離タイプのインタプリタを一部修正したものなので本文中の実装とはちょっと違います。
このインタプリタは以下の不具合があります。
- lambdaを評価して印字するとスタックがあふれてエラーになる
- 末尾再帰最適化が出来ない
遅延評価がどうやって行われているのかについては学習できたので
不具合について対処しないで先に進むことにしました。
遅延評価をさせる要点は以下の2点でした。
- 引数の評価は全て遅延させる
- プリミティブな関数に渡す際に引数を評価する
この２つの条件を守れば遅延評価するインタプリタになると思います。
4.2の演習問題はあまり興味が無かったのでやっていません。
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; for debug ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (println . exps) (let loop ((exps exps)) (if (null? exps) (newline) (begin (display (car exps)) (loop (cdr exps)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; boolean and comparison functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (false? val) (equal? val 'false)) (define (true? val) (not (false? val))) (define (make-comparison compare) (lambda (base . comparison-values) (let loop ((vs comparison-values)) (cond ((null? vs) 'true) ((compare base (car vs)) (loop (cdr vs))) (else 'false))))) (define >? (make-comparison >)) (define <? (make-comparison <)) (define =? (make-comparison =)) (define (primitive-equal? l r) (if (equal? l r) 'true 'false)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; environment ; ; environment structure: ; '(((a . 1) (b . 1)) <= newest frame ; ((a . 2) (b . 2) (c . 3)) ; .... ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (setup-environment) (let* ((env `(((true . true) (false . false) ; (car . (primitive . ,car)) ; (cdr . (primitive . ,cdr)) ; (cons . (primitive . ,cons)) (+ . (primitive . ,+)) (- . (primitive . ,-)) (* . (primitive . ,*)) (/ . (primitive . ,/)) (> . (primitive . ,>?)) (< . (primitive . ,<?)) (equal? . (primitive . ,primitive-equal?)) (= . (primitive . ,=?)) (println. (primitive . ,println))))) (lazy-cons ((analyze '(define (cons x y) (lambda (f) (f x y)))) env)) (lazy-car ((analyze '(define (car cell) (cell (lambda (x y) x)))) env)) (lazy-cdr ((analyze '(define (cdr cell) (cell (lambda (x y) y)))) env))) env)) (define (lookup-var-val var env) (let loop ((frames env)) (cond ((null? frames) (error "not found " var)) (else (let ((var-val (assoc var (car frames)))) (if var-val (cdr var-val) (loop (cdr frames)))))))) (define (set-var-val! var val env) (let loop ((frames env)) (if (null? frames) (error "unbounded variable" var) (let ((var-val (assoc var (car frames)))) (if var-val (let ((ret (cdr var-val))) (set-cdr! var-val val)) (loop (cdr frames))))))) (define (define-var-val! var val env) (set-car! env (cons (cons var val) (car env)))) (define (extend-env vars vals env) (cons (map cons vars vals) env)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; analyze functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; self-evaluating (define (self-evaluating? exp) (or (number? exp) (string? exp))) (define (analyze-self-evaluating exp) (lambda (env) exp)) (define (analyze-quoted exp) (let ((qvs (cadr exp))) (lambda (env) qvs))) ;; symbol (define (analyze-symbol exp) (lambda (env) (let ((result (lookup-var-val exp env))) (if (and (pair? result) (thunk? result)) (force-it result) result)))) ;; quote (define (syntax-check symbol) (lambda (exp) (and (pair? exp) (equal? (car exp) symbol)))) (define quoted? (syntax-check 'quote)) ;; if (define (analyze-if exp) (let ((predicate (analyze (cadr exp))) (consequent (analyze (caddr exp))) (alternative (if (not (null? (cdddr exp))) (analyze (cadddr exp)) (lambda (env) 'none)))) (lambda (env) (if (true? (predicate env)) (consequent env) (alternative env))))) ;; set (define (analyze-set exp) (let ((var (cadr exp)) (val (analyze (caddr exp)))) (lambda (env) (set-var-val! var (delay-it val env) env)))) (define (syntax? exp) (and (pair? exp) (assoc (car exp) syntaxes))) (define (analyze-syntax exp) (let ((syntax (cdr (assoc (car exp) syntaxes)))) (syntax exp))) ;; lambda (define (make-lambda args procs) (cons 'lambda (cons args procs))) (define (make-procedure vars procs env) (list 'procedure vars procs env)) (define (analyze-lambda exp) (let ((vars (cadr exp)) (procs (analyze-sequence (cddr exp)))) (lambda (env) (make-procedure vars procs env)))) ;; sequence (define (analyze-sequence exps) (let loop ((procs (map analyze exps))) (cond ((null? procs) (error "analyze-sequence: fail")) ((null? (cdr procs)) (lambda (env) (force-it ((car procs) env)))) (else (lambda (env) (force-it ((car procs) env)) ((loop (cdr procs)) env)))))) ;; define (define (definition-variable exp) (if (symbol? (cadr exp)) (cadr exp) (caadr exp))) (define (definition-value exp) (if (symbol? (cadr exp)) (caddr exp) (make-lambda (cdadr exp) (cddr exp)))) (define (analyze-define exp) (let ((var (definition-variable exp)) (vproc (analyze (definition-value exp)))) (lambda (env) (define-var-val! var (delay-it vproc env) env) 'ok))) ;; let (define (analyze-let exp) (if (symbol? (cadr exp)) (let* ((name (cadr exp)) (vars (map (lambda (var-val) (car var-val)) (caddr exp))) (vals (map (lambda (var-val) (analyze (cadr var-val))) (caddr exp))) (procs (analyze (make-lambda vars (cdddr exp))))) (lambda (env) (let ((args (map (lambda (arg) (arg env)) vals))) (define-var-val! name (procs env) env) (execute (force-it (procs env)) (map (lambda (arg) (if (thunk-cell? arg) arg (delay-it arg env))) vals))))) (let ((vars (map (lambda (var-val) (car var-val)) (cadr exp))) (vals (map (lambda (var-val) (analyze (cadr var-val))) (cadr exp))) (procs (analyze-sequence (cddr exp)))) (lambda (env) (let ((procedure (make-procedure vars procs env))) (execute (force-it procedure) (map (lambda (arg) (if (thunk-cell? arg) arg (delay-it arg env))) vals))))))) ;; delay and force (define (delay-it exp env) (list 'thunk exp env)) (define (thunk? obj) (equal? (car obj) 'thunk)) (define (evaluated-thunk? obj) (equal? (car obj) 'evaluated-thunk)) (define (thunk-cell? obj) (and (pair? obj) (or (thunk? obj) (evaluated-thunk? obj)))) (define (force-it obj) (cond ((and (pair? obj) (thunk? obj)) (let* ((thunk-exp (cadr obj)) (thunk-env (caddr obj)) (result (thunk-exp thunk-env))) (set-car! obj 'evaluated-thunk) (set-car! (cdr obj) result) (set-cdr! (cdr obj) '()) result)) ((and (pair? obj) (evaluated-thunk? obj)) (cadr obj)) (else obj))) ;; application (define (analyze-application exp) (let ((proc (analyze (car exp))) (args (map analyze (cdr exp)))) (lambda (env) (execute (force-it (proc env)) (map (lambda (arg) (if (thunk-cell? arg) arg (delay-it arg env))) args))))) (define (application? exp) (pair? exp)) (define (primitive? proc) (equal? (car proc) 'primitive)) (define (procedure? proc) (equal? (car proc) 'procedure)) ;; apply (define (execute proc args) (cond ((primitive? proc) (apply (cdr proc) (map (lambda (arg) (let loop ((arg arg)) (if (thunk-cell? arg) (loop (force-it arg)) arg))) args))) ((procedure? proc) ((caddr proc) (extend-env (cadr proc) args (cadddr proc)))) (else (error "execute fail:")))) ;; analyze (define syntaxes `((if . ,analyze-if) (set! . ,analyze-set) (begin . ,analyze-sequence) (lambda . ,analyze-lambda) (define . ,analyze-define) (let . ,analyze-let))) (define (analyze exp) (cond ((self-evaluating? exp)(analyze-self-evaluating exp)) ((quoted? exp) (analyze-quoted exp)) ((symbol? exp) (analyze-symbol exp)) ((syntax? exp) (analyze-syntax exp)) ((application? exp) (analyze-application exp)) (else (error "analyze fail: unknown type")))) (define (analyze-loop) (let ((global-env (setup-environment)) (read-sexp (lambda () (newline) (display "> ") (newline) (read)))) (let loop () (let ((result ((analyze (read-sexp)) global-env))) (cond ((equal? 'quit result) 'quit) (else (display result) (loop)))))))
