SICP 問題 4.31

(define (f a (b lazy) c (d lazy-memo))
  ...)

といった形で部分的に遅延評価やメモ化する遅延評価を実装する．
　
元となるのは4.30までで作っていた遅延評価器．
まず変更した部分を書く．

;; メモ化する評価器
(define (force-it obj)
  (cond ((thunk? obj) (actual-value (thunk-exp obj) (thunk-env obj))) ;;メモ化しない遅延
        ((thunk-memo? obj) ;;メモ化する遅延
         (let ((result (actual-value (thunk-exp obj)
                                     (thunk-env obj))))
           (set-car! obj 'evaluated-thunk)
           (set-car! (cdr obj) result)
           (set-cdr! (cdr obj) '())
           result))
        ((evaluated-thunk? obj) (thunk-value obj))
        (else obj)))

(define (delay-it exp env) (list 'thunk exp env))           ;;これはそのまま
(define (delay-memo-it exp env) (list 'thunk-memo exp env)) ;;thunk-memoにする
(define (thunk? exp) (tagged-list? exp 'thunk))
(define (thunk-memo? exp) (tagged-list? exp 'thunk-memo)) ;;追加
(define (thunk-exp thunk) (cadr thunk))
(define (thunk-env thunk) (caddr thunk))

;; apply
(define (my-apply procedure arguments env)
  (cond ((primitive-procedure? procedure)
         (apply-primitive-procedure
          procedure
          (list-of-arg-values arguments env)))
        ((compound-procedure? procedure)
         (eval-sequence
          (procedure-body procedure)
          (extend-environment (procedure-parameters procedure)
                              (list-of-args-thunk-or-values
                               (origin-procedure-parameters procedure) arguments env) ;;仮引数のリストも渡す
                              (procedure-environment procedure))))
        (else (error "Unknown procedure type: APPLY" procedure))))

;; 変更なし
(define (list-of-arg-values exps env)
  (if (no-operands? exps)
      '()
      (cons (actual-value (first-operand exps) env)
            (list-of-arg-values (rest-operands exps) env))))

;; 一番目の仮引数を見て，pairならlazyかlazy-memoのどちらか調べてthunk or thunk-memoにする．
;; pairでなければactual-valueして仮引数に束縛する．
;; procedure-parametersではpairなら(a lazy)のような形をaに変えて渡す．
;; origin-procedure-parametersはそのまま渡す．
(define (list-of-args-thunk-or-values parameters exps env)
  (if (no-operands? exps)
      '()
      (let ((first (first-parameter parameters)))
        (cond ((pair? first)
               (cond ((lazy? first)
                      (cons (delay-it (first-operand exps) env)
                            (list-of-args-thunk-or-values (rest-parameters parameters) (rest-operands exps) env)))
                     ((lazy-memo? first)
                      (cons (delay-memo-it (first-operand exps) env) ;;遅延させてメモ化する
                            (list-of-args-thunk-or-values (rest-parameters parameters) (rest-operands exps) env)))
                     (else (error "require lazy or lazy-memo option, but get " first))))
              (else (cons (actual-value (first-operand exps) env)
                          (list-of-args-thunk-or-values (rest-parameters parameters) (rest-operands exps) env)))))))

(define (first-parameter parameters) (car parameters))
(define (rest-parameters parameters) (cdr parameters))
(define (lazy? parameter) (eq? (cadr parameter) 'lazy))
(define (lazy-memo? parameter) (eq? (cadr parameter) 'lazy-memo))
(define (origin-procedure-parameters procedure) (cadr procedure))

(define (procedure-parameters p) (map (lambda (x) (if (pair? x) (car x) x)) (cadr p)))

;; lazyとlazy-memoを基本手続きに追加してeq?で
マッチできるようにした．
(define primitive-procedures
  (list (list 'car car)
        (list 'cdr cdr)
        (list 'cons cons)
        (list 'null? null?)
        (list '= =)
        (list '- -)
        (list '+ +)
        (list '* *)
        (list '/ /)
        (list 'newline newline)
        (list 'display display)
        (list 'lazy 'lazy)
        (list 'lazy-memo 'lazy-memo)))

テスト

;; 遅延評価自体のテスト
;;; M-Eval input:
(define (try a (b lazy))
        (if (= a 0) 1 b))

;;; M-Eval value:
ok

;;; M-Eval input:
(try 0 (/ 1 0))

;;; M-Eval value:
1

;;; M-Eval input:
(define (try (a lazy-memo) b)
        (if (= b 0) 1 a))

;;; M-Eval value:
ok

;;; M-Eval input:
(try (/ 1 0) 0)

;;; M-Eval value:
1

lazyもlazy-memoのどちらの評価も遅延されている． 次にメモ化のテストをする．
ここではフィボナッチ数列の計算をさせる．

;; まずは作用的順序の評価
;;; M-Eval input:
(define (fib n)
  (let iter ((a 0) (b 1) (count n))
    (if (= n 0)
        a
        (iter b (+ a b) (- n 1)))))
;(time (actual-value input the-global-environment))
; real   0.000
; user   0.000
; sys    0.000

;;; M-Eval value:
ok

;;; M-Eval input:
(fib 10000)
;(time (actual-value input the-global-environment))
; real   0.200
; user   0.210
; sys    0.000

;;; M-Eval value:
33644764876431783266621612005107543310302148460680063906564769974680081442166662368155595513633734025582065332680836159373734790483865268263040892463056431887354544369559827491606602099884183933864652731300088830269235673613135117579297437854413752130520504347701602264758318906527890855154366159582987279682987510631200575428783453215515103870818298969791613127856265033195487140214287532698187962046936097879900350962302291026368131493195275630227837628441540360584402572114334961180023091208287046088923962328835461505776583271252546093591128203925285393434620904245248929403901706233888991085841065183173360437470737908552631764325733993712871937587746897479926305837065742830161637408969178426378624212835258112820516370298089332099905707920064367426202389783111470054074998459250360633560933883831923386783056136435351892133279732908133732642652633989763922723407882928177953580570993691049175470808931841056146322338217465637321248226383092103297701648054726243842374862411453093812206564914032751086643394517512161526545361333111314042436854805106765843493523836959653428071768775328348234345557366719731392746273629108210679280784718035329131176778924659089938635459327894523777674406192240337638674004021330343297496902028328145933418826817683893072003634795623117103101291953169794607632737589253530772552375943788434504067715555779056450443016640119462580972216729758615026968443146952034614932291105970676243268515992834709891284706740862008587135016260312071903172086094081298321581077282076353186624611278245537208532365305775956430072517744315051539600905168603220349163222640885248852433158051534849622434848299380905070483482449327453732624567755879089187190803662058009594743150052402532709746995318770724376825907419939632265984147498193609285223945039707165443156421328157688908058783183404917434556270520223564846495196112460268313970975069382648706613264507665074611512677522748621598642530711298441182622661057163515069260029861704945425047491378115154139941550671256271197133252763631939606902895650288268608362241082050562430701794976171121233066073310059947366875

;; 次は遅延評価
;;; M-Eval input:
(define (fib-lazy n)
  (let iter (((a lazy) 0) ((b lazy) 1) ((count lazy) n))
    (if (= count 0)
        a
        (iter b (+ a b) (- count 1)))))
;(time (actual-value input the-global-environment))
; real   0.000
; user   0.000
; sys    0.000

;;; M-Eval value:
ok

;;; M-Eval input:
(fib-lazy 30)
;(time (actual-value input the-global-environment))
; real   7.277
; user   7.440
; sys    0.020

;;; M-Eval value:
832040

;; メモ化された遅延評価のテスト
;;; M-Eval input:
(define (fib-lazy-memo n)
  (let iter (((a lazy-memo) 0) ((b lazy-memo) 1) ((count lazy-memo) n))
    (if (= count 0)
        a
        (iter b (+ a b) (- count 1)))))
;(time (actual-value input the-global-environment))
; real   0.000
; user   0.000
; sys    0.000

;;; M-Eval value:
ok

;;; M-Eval input:
(fib-lazy-memo 30)
;(time (actual-value input the-global-environment))
; real   0.001
; user   0.000
; sys    0.000

;;; M-Eval value:
832040

;;; M-Eval input:
(fib-lazy-memo 10000)
;(time (actual-value input the-global-environment))
; real   0.234
; user   0.250
; sys    0.010

;;; M-Eval value:
33644764876431783266621612005107543310302148460680063906564769974680081442166662368155595513633734025582065332680836159373734790483865268263040892463056431887354544369559827491606602099884183933864652731300088830269235673613135117579297437854413752130520504347701602264758318906527890855154366159582987279682987510631200575428783453215515103870818298969791613127856265033195487140214287532698187962046936097879900350962302291026368131493195275630227837628441540360584402572114334961180023091208287046088923962328835461505776583271252546093591128203925285393434620904245248929403901706233888991085841065183173360437470737908552631764325733993712871937587746897479926305837065742830161637408969178426378624212835258112820516370298089332099905707920064367426202389783111470054074998459250360633560933883831923386783056136435351892133279732908133732642652633989763922723407882928177953580570993691049175470808931841056146322338217465637321248226383092103297701648054726243842374862411453093812206564914032751086643394517512161526545361333111314042436854805106765843493523836959653428071768775328348234345557366719731392746273629108210679280784718035329131176778924659089938635459327894523777674406192240337638674004021330343297496902028328145933418826817683893072003634795623117103101291953169794607632737589253530772552375943788434504067715555779056450443016640119462580972216729758615026968443146952034614932291105970676243268515992834709891284706740862008587135016260312071903172086094081298321581077282076353186624611278245537208532365305775956430072517744315051539600905168603220349163222640885248852433158051534849622434848299380905070483482449327453732624567755879089187190803662058009594743150052402532709746995318770724376825907419939632265984147498193609285223945039707165443156421328157688908058783183404917434556270520223564846495196112460268313970975069382648706613264507665074611512677522748621598642530711298441182622661057163515069260029861704945425047491378115154139941550671256271197133252763631939606902895650288268608362241082050562430701794976171121233066073310059947366875

遅延評価，メモ化ともに正常に働いている．
最後にこの評価器のソースを貼っておく．

(define true #t)
(define false #f)

(define (eval exp env)
  (cond ((self-evaluating? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))
        ((quoted? exp) (text-of-quotation exp))
        ((assignment? exp) (eval-assignment exp env))
        ((definition? exp) (eval-definition exp env))
        ((if? exp) (eval-if exp env))
        ((lambda? exp)
         (make-procedure (lambda-parameters exp)
                         (lambda-body exp)
                         env))
        ((let? exp) (eval (let->combination exp) env))
        ((let*? exp) (eval (let*->nested-lets exp) env))
        ((letrec? exp) (eval (letrec->let exp) env)) ;;letrecを追加
        ((begin? exp)
         (eval-sequence (begin-actions exp) env))
        ((cond? exp) (eval (cond->if exp) env))
        ((and? exp) (eval-and exp env))
        ((or? exp) (eval-or exp env))
        ((application? exp)
         (my-apply (actual-value (operator exp) env)
                   (operands exp)
                   env))
        (else
         (error "Unknown expression type --EVAL" exp))))

;; メモ化する評価器
(define (force-it obj)
  (cond ((thunk? obj) (actual-value (thunk-exp obj) (thunk-env obj))) ;;メモ化しない遅延
        ((thunk-memo? obj) ;;メモ化する遅延
         (let ((result (actual-value (thunk-exp obj)
                                     (thunk-env obj))))
           (set-car! obj 'evaluated-thunk)
           (set-car! (cdr obj) result)
           (set-cdr! (cdr obj) '())
           result))
        ((evaluated-thunk? obj) (thunk-value obj))
        (else obj)))

(define (delay-it exp env) (list 'thunk exp env))           ;;これはそのまま
(define (delay-memo-it exp env) (list 'thunk-memo exp env)) ;;thunk-memoにする
(define (thunk? exp) (tagged-list? exp 'thunk))
(define (thunk-memo? exp) (tagged-list? exp 'thunk-memo)) ;;追加
(define (thunk-exp thunk) (cadr thunk))
(define (thunk-env thunk) (caddr thunk))

(define (evaluated-thunk? obj) (tagged-list? obj 'evaluated-thunk))
(define (thunk-value evaluated-thunk) (cadr evaluated-thunk))

(define (actual-value exp env)
  (force-it (eval exp env)))

;; apply
(define (my-apply procedure arguments env)
  (cond ((primitive-procedure? procedure)
         (apply-primitive-procedure
          procedure
          (list-of-arg-values arguments env)))
        ((compound-procedure? procedure)
         (eval-sequence
          (procedure-body procedure)
          (extend-environment (procedure-parameters procedure)
                              (list-of-args-thunk-or-values
                               (origin-procedure-parameters procedure) arguments env) ;;仮引数のリストも渡す
                              (procedure-environment procedure))))
        (else (error "Unknown procedure type: APPLY" procedure))))

;; 変更なし
(define (list-of-arg-values exps env)
  (if (no-operands? exps)
      '()
      (cons (actual-value (first-operand exps) env)
            (list-of-arg-values (rest-operands exps) env))))

;; 一番目の仮引数を見て，pairならlazyかlazy-memoのどちらか調べてthunk or thunk-memoにする．
;; pairでなければactual-valueして仮引数に束縛する．
;; procedure-parametersではpairなら(a lazy)のような形をaに変えて渡す．
;; origin-procedure-parametersはそのまま渡す．
(define (list-of-args-thunk-or-values parameters exps env)
  (if (no-operands? exps)
      '()
      (let ((first (first-parameter parameters)))
        (cond ((pair? first)
               (cond ((lazy? first)
                      (cons (delay-it (first-operand exps) env)
                            (list-of-args-thunk-or-values (rest-parameters parameters) (rest-operands exps) env)))
                     ((lazy-memo? first)
                      (cons (delay-memo-it (first-operand exps) env) ;;遅延させてメモ化する
                            (list-of-args-thunk-or-values (rest-parameters parameters) (rest-operands exps) env)))
                     (else (error "require lazy or lazy-memo option, but get " first))))
              (else (cons (actual-value (first-operand exps) env)
                          (list-of-args-thunk-or-values (rest-parameters parameters) (rest-operands exps) env)))))))

(define (first-parameter parameters) (car parameters))
(define (rest-parameters parameters) (cdr parameters))
(define (lazy? parameter) (eq? (cadr parameter) 'lazy))
(define (lazy-memo? parameter) (eq? (cadr parameter) 'lazy-memo))
(define (origin-procedure-parameters procedure) (cadr procedure))

;; 条件式
(define (eval-if exp env)
  (if (true? (actual-value (if-predicate exp) env))
      (eval (if-consequent exp) env)
      (eval (if-alternative exp) env)))

;; 並び
(define (eval-sequence exps env)
  (cond ((last-exp? exps) (eval (first-exp exps) env))
        (else (eval (first-exp exps) env)
              (eval-sequence (rest-exps exps) env))))

;; 代入
(define (eval-assignment exp env)
  (set-variable-value! (assignment-variable exp)
                       (eval (assignment-value exp) env)
                       env)
  'ok)

;; 定義
(define (eval-definition exp env)
  (define-variable!
    (definition-variable exp)
    (eval (definition-value exp) env)
    env)
  'ok)

;; 自己評価式
(define (self-evaluating? exp)
  (cond ((number? exp) true)
        ((string? exp) true)
        (else false)))

;; 変数
(define (variable? exp) (symbol? exp))

;; クオート
(define (quoted? exp)
  (tagged-list? exp 'quote))

(define (text-of-quotation exp) (cadr exp))

(define (tagged-list? exp tag)
  (if (pair? exp)
      (eq? (car exp) tag)
      false))

;; 代入
(define (assignment? exp)
  (tagged-list? exp 'set!))

(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))

;; 定義
(define (definition? exp)
  (tagged-list? exp '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)))) ;;本体

;; lambda式
(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))

(define (make-lambda parameters body)
  (cons 'lambda (cons parameters body)))

;; if
(define (if? exp) (tagged-list? exp 'if))
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
  (if (not (null? (cdddr exp)))
      (cadddr exp)
      'false))

(define (make-if predicate consequent alternative)
  (list 'if predicate consequent alternative))

;; begin
(define (begin? exp) (tagged-list? exp 'begin))
(define (begin-actions exp) (cdr exp))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))

(define (sequence->exp seq)
  (cond ((null? seq) seq)
        ((last-exp? seq) (first-exp seq))
        (else (make-begin seq))))

(define (make-begin seq) (cons 'begin seq))


;; 任意の合成式
(define (application? exp) (pair? exp))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
(define (no-operands? ops) (null? ops))
(define (first-operand ops) (car ops))
(define (rest-operands ops) (cdr ops))

;; 派生式
(define (cond? exp) (tagged-list? exp 'cond))
(define (cond-clauses exp) (cdr exp))
(define (cond-else-clause? clause)
  (eq? (cond-predicate clause) 'else))
(define (cond-predicate clause) (car clause))
(define (cond-actions clause) (cdr clause))

(define (cond->if exp)
  (expand-clauses (cond-clauses exp)))

(define (expand-clauses clauses)
  (if (null? clauses)
      'false
      (let ((first (car clauses))
            (rest (cdr clauses)))
        (if (cond-else-clause? first)
            (if (null? rest)
                (sequence->exp (cond-actions first))
                (error "ELSE clause isn't last -- COND->IF" clauses))
            (let ((action (cond-actions first))
                  (predicate (cond-predicate first)))
              (make-if predicate
                       (if (eq? (car action) '=>)
                           (list (cadr action) predicate)
                           (sequence->exp action))
                       (expand-clauses rest)))))))

;; and
(define (and? exp) (tagged-list? exp 'and))
(define (and-clauses exp) (cdr exp))

(define (eval-and exp env)
  (let iter ((clauses (and-clauses exp)))
    (if (null? clauses)
        'true
        (let ((first (eval (car clauses) env)))
          (cond ((null? (cdr clauses)) first)
                (first (iter (cdr clauses)))
                (else 'false))))))


;; or
(define (or? exp) (tagged-list? exp 'or))
(define (or-clauses exp) (cdr exp))

(define (eval-or exp env)
  (let iter ((clauses (or-clauses exp)))
    (if (null? clauses)
        'false
        (let ((first (eval (car clauses) env)))
          (cond ((null? (cdr clauses)) first)
                (first 'true)
                (else (iter (cdr clauses))))))))


;; let
(define (let? exp) (tagged-list? exp 'let))
(define (let-parameters exp) (cadr exp))
(define (let-variables exp) (map car (let-parameters exp)))
(define (let-expressions exp) (map cadr (let-parameters exp)))
(define (let-bodys exp) (cddr exp))

(define (let->combination exp)
  (if (symbol? (cadr exp)) ;; 2番目の要素がシンボルならnamed-let
      (named-let->define (named-let-func-name exp)
                         (named-let-variables exp)
                         (named-let-expressions exp)
                         (named-let-bodys exp))
      (cons (make-lambda (let-variables exp)
                     (let-bodys exp))
        (let-expressions exp))))

;; let*
(define (let*? exp) (tagged-list? exp 'let*))
(define (let*-parameters exp) (cadr exp))
(define (let*-variables exp) (map car (let*-parameters exp)))
(define (let*-expressions exp) (map cadr (let*-parameters exp)))
(define (let*-body exp) (cddr exp))

(define (make-let parameters bodys)
  (cons 'let (cons parameters bodys)))

(define (let*->nested-lets exp)
  (expand-lets (let-parameters exp) (let-bodys exp)))

(define (expand-lets parameters bodys)
  (cond ((null? parameters) (error "EXPAND-LETS required pair, but " parameters))
        ((null? (cdr parameters))
         (make-let (list (car parameters))
                   bodys))
        (else (make-let (list (car parameters))
                        (list (expand-lets (cdr parameters) bodys))))))


;; named-let
(define (named-let? exp) (symbol? (cadr exp)))
(define (named-let-func-name exp) (cadr exp))
(define (named-let-parameters exp) (caddr exp))
(define (named-let-variables exp) (map car (named-let-parameters exp)))
(define (named-let-expressions exp) (map cadr (named-let-parameters exp)))
(define (named-let-bodys exp) (cdddr exp))

(define (make-definition variable value)
  (list 'define variable value))


(define (named-let->define func-name variables expressions bodys)
  (make-begin (list (make-definition func-name (make-lambda variables bodys))
                    (cons func-name expressions))))

;; letrec
(define (letrec? exp) (tagged-list? exp 'letrec))
(define (letrec-parameters exp) (cadr exp))
(define (letrec-variables exp) (map car (letrec-parameters exp)))
(define (letrec-expressions exp) (map cadr (letrec-parameters exp)))
(define (letrec-body exp) (cddr exp))

(define (letrec->let exp)
  (make-let (map (lambda (x) (list x ''*unassigned*))
                 (letrec-variables exp))
            (append (map (lambda (x y) (list 'set! x y))
                         (letrec-variables exp)
                         (letrec-expressions exp))
                    (letrec-body exp))))

;; 術後のテスト
(define (true? x)
  (not (eq? x '#f)))
(define (false? x)
  (eq? x '#f))

;; 手続きの表現
(define (make-procedure parameters body env)
  (list 'procedure parameters (scan-out-defines body) env))
(define (compound-procedure? p)
  (tagged-list? p 'procedure))
(define (procedure-parameters p) (map (lambda (x) (if (pair? x) (car x) x)) (cadr p)))
(define (procedure-body p) (caddr p))
(define (procedure-environment p) (cadddr p))

;; 環境に対する操作
(define (enclosing-environment env) (cdr env))
(define (first-frame env) (car env))
(define the-empty-environment '())

;; フレーム
(define (make-frame variables values)
  (cons variables values))
(define (frame-variables frame) (car frame))
(define (frame-values frame) (cdr frame))

(define (add-binding-to-frame! var val frame)
  (set-car! frame (cons var (frame-variables frame)))
  (set-cdr! frame (cons val (frame-values frame))))

;; 変数を値に対応づける新しいフレーム
(define (extend-environment vars vals base-env)
  (if (= (length vars) (length vals))
      (cons (make-frame vars vals) base-env)
      (if (< (length vars) (length vals))
          (error "Too many arguments supplied" vars vals)
          (error "Too few arguments supplied" vars vals))))

(define (lookup-variable-value var env)
  (define (env-loop env)
    (define (scan vars vals)
      (cond ((null? vars)
             (env-loop (enclosing-environment env)))
            ((eq? var (car vars))
             (if (eq? (car vals) '*unassigned*)
                 (error "*Unassigned* variable" var)
                 (car vals)))
            (else (scan (cdr vars) (cdr vals)))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable" var)
        (let ((frame (first-frame env)))
          (scan (frame-variables frame)
                (frame-values frame)))))
  (env-loop env))

(define (set-variable-value! var val env)
  (define (env-loop env)
    (define (scan vars vals)
      (cond ((null? vars)
             (env-loop (enclosing-environment env)))
            ((eq? var (car vars))
             (set-car! vals val))
            (else (scan (cdr vars) (cdr vals)))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable -- SET!" var)
        (let ((frame (first-frame env)))
          (scan (frame-variables frame)
                (frame-values frame)))))
  (env-loop env))

(define (define-variable! var val env)
  (let ((frame (first-frame env)))
    (define (scan vars vals)
      (cond ((null? vars)
             (add-binding-to-frame! var val frame))
            ((eq? var (car vars))
             (set-car! vals val))
            (else (scan (cdr vars) (cdr vals)))))
    (scan (frame-variables frame)
          (frame-values frame))))

(define (primitive-procedure? proc)
  (tagged-list? proc 'primitive))

(define (primitive-implementation proc) (cadr proc))

(define primitive-procedures
  (list (list 'car car)
        (list 'cdr cdr)
        (list 'cons cons)
        (list 'null? null?)
        (list '= =)
        (list '- -)
        (list '+ +)
        (list '* *)
        (list '/ /)
        (list 'newline newline)
        (list 'display display)
        (list 'lazy 'lazy)
        (list 'lazy-memo 'lazy-memo)))

(define (primitive-procedure-names)
  (map car primitive-procedures))

(define (primitive-procedure-objects)
  (map (lambda (proc) (list 'primitive (cadr proc)))
       primitive-procedures))

(define (apply-primitive-procedure proc args)
  (apply-in-underlying-scheme
   (primitive-implementation proc) args))

(define apply-in-underlying-scheme apply)

;; 環境
(define (setup-environment)
  (let ((initial-env
         (extend-environment (primitive-procedure-names)
                             (primitive-procedure-objects)
                             the-empty-environment)))
    (define-variable! 'true #t initial-env)
    (define-variable! 'false #f initial-env)
    initial-env))

(define the-global-environment (setup-environment))

(define input-prompt ";;; M-Eval input:")
(define output-prompt ";;; M-Eval value:")

(define (driver-loop)
  (prompt-for-input input-prompt)
  (let ((input (read)))
    (let ((output (time (actual-value input the-global-environment))))
      (announce-output output-prompt)
      (user-print output)))
  (driver-loop))

(define (prompt-for-input string)
  (newline)
  (newline)
  (display string)
  (newline))

(define (announce-output string)
  (newline)
  (display string)
  (newline))

(define (user-print object)
  (if (compound-procedure? object)
      (display (list 'compound-procedure
                     (procedure-parameters object)
                     (procedure-body object)
                     '<procedure-env>))
      (display object)))

;; lambda式
(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))

(define (make-lambda parameters body)
  (cons 'lambda (cons parameters body)))

(define (def-body-list proc-body)
  (let iter ((proc-body proc-body)
             (def '())
             (body '()))
    (cond ((null? proc-body) (cons (reverse def) (reverse body)))
          ((definition? (car proc-body)) (iter (cdr proc-body)
                                               (cons (car proc-body) def)
                                               body))
          (else (iter (cdr proc-body)
                      def
                      (cons (car proc-body) body))))))

(define (scan-out-defines body)
  (define (split-def-body proc-body)
    (let iter ((proc-body proc-body)
               (def '())
               (body '()))
      (cond ((null? proc-body) (cons (reverse def) (reverse body)))
            ((definition? (car proc-body)) (iter (cdr proc-body)
                                                 (cons (car proc-body) def)
                                                 body))
            (else (iter (cdr proc-body)
                        def
                        (cons (car proc-body) body))))))
  (let* ((def-body-list (split-def-body body))
         (def-list (car def-body-list))
         (body-list (cdr def-body-list)))
    (if (null? def-list)
        body
        (append  (map (lambda (x) (make-definition (definition-variable x) ''*unassigned*))
                    def-list)
                 (map (lambda (x) (list 'set! (definition-variable x)
                                        (definition-value x)))
                      def-list)
                 body-list))))