問題4.27の前(遅延評価を組み込んだ評価器)

遅延評価を組み込んだ評価器のソース。
この節で使用する評価器は解析と評価を分離していない方を元に遅延評価を組み込む。
問題4.27のためメモ化したthunkの部分はコメントアウトしてある。

;; 評価器実行用に超循環のapplyを定義する前に定義しておく
(define apply-in-underlying-scheme apply)
(define true #t)
(define false #f)
;; ---------------------------------------------
;; 評価器の中核
;; ---------------------------------------------
;; apply の方がevalより前でないとダメ
;; apply
;; 4.2.2節で修正
;; (define (apply procedure arguments)
(define (apply procedure arguments env)
  (cond ((primitive-procedure? procedure)
         ;; (apply-primitive-procedure procedure arguments))
         (apply-primitive-procedure 
          procedure
          (list-of-arg-values arguments env)))
        ((compound-procedure? procedure)
         (eval-sequence
          (procedure-body procedure)
          (extend-environment
           (procedure-parameters procedure)
           ;; arguments
           (list-of-delayed-args arguments env)
           (procedure-environment procedure))))
        (else
         (error "Unknown procedure type -- APPLY" procedure))))
;; 4.2.2節で追加
(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))))
(define (list-of-delayed-args exps env)
  (if (no-operands? exps)
      '()
      (cons (delay-it (first-operand exps) env)
            (list-of-delayed-args (rest-operands exps)
                                  env))))

;; eval
(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))
        ((unbind? exp) (eval-unbind! 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)) ; 追加
        ((while? exp) (eval (while->named-let exp) env))
        ((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))
        ;; 4.2.2節で変更
        ;; ((application? exp)
        ;; (apply (eval (operator exp) env)
        ;;         (list-of-values (operands exp) env)))
        ((application? exp)
         (apply (actual-value (operator exp) env)
                (operands exp)
                env))
        (else
         (error "Unknown expression type -- EVAL" exp))))
;; 4.2.2節で追加
(define (actual-value exp env)
  (force-it (eval exp env)))

;; 手続きの引数
;; 4.2.2節で不要に
;; (define (list-of-values exps env)
;;   (if (no-operands? exps)
;;       '()
;;       (cons (eval (first-operand exps) env)
;;             (list-of-values (rest-operands exps) env))))

;; 条件式
;; 4.2.2節で修正
(define (eval-if exp env)
;;   (if (true? (eval (if-predicate 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 (unbind? exp)
  (tagged-list? exp 'unbind!))
(define (eval-unbind! exp env)
  (unbind-variable! (definition-variable exp) env))

;; 式の表現
;; 自己評価式は数と文字列だけである
(define (self-evaluating? exp)
  (cond ((number? exp) true)
        ((string? exp) true)
        (else false)))

;; 変数は記号で表現する
(define (variable? exp) (symbol? exp))

;; クォート式は(quote <text-of-quotation>)の形である('aも(quote a)に見える)
(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))

;; 代入は(set! <var> <value>)の形である
(define (assignment? exp)
  (tagged-list? exp 'set!))
(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))

;; 定義は
;; (define <var> <value>)
;; または
;; (define (<var> <parameter1> ... <parametern>)
;;   <body>)
;; の形である。後の形(標準手続き定義)は
;; (define <var>
;;   (lambda (<parameter1> ... <parametern>)
;;     <body>)
;; の構文シュガーである。
(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)   ; formal parameters
                   (cddr exp)))) ; body

;; lambda式は記号lambdaで始まるリストである
(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))

;; 上のdefienition-valueが使うlambda式の構成子
(define (make-lambda parameters body)
  (cons 'lambda (cons parameters body)))

;; 条件はifで始まり、述語と帰結部(場合により)代替部を持つ。式に代替部がなければ、代替部としてfalseを置く。
(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))
      'false))
;; cond式をif式に変換するcnod->ifに使うif式の構成子
(define (make-if predicate consequent alternative)
  (list 'if predicate consequent alternative))

;; begin式は式の並びを単一の式に包み込む。begin式から実際の並びが取れるように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))
; (cond->ifが使う)構成子sequence->exp
(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))

;; 手続き作用。上の式の形のいずれでもない任意の合成式。式のcarが演算子,cdrが被演算子のリスト
(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))

;; 導出された式。特殊形式のあるものは直接実装するのでなはなく、他の特殊形式を使った式の形で定義できる。その一例がcondで、if式の入れ子として実装できる。condの評価をこのように実装すると評価プロセスに明確に規定しなければならない特殊形式の数が減るので評価器が単純になる
;; cond式の要素を取り出す構文手続きとcond式をif式に変換する手続きcond->ifを用意する。場合分けはcondで始まり、述語と行動の節のリストを持つ。述語が記号elseの時、節はelse節である。
;; 拡張構文を追加したcond
(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 (extended-cond? clause)
  (if (cond-else-clause? clause)
      false
      (eq? (cadr clause) '=>)))
;; 拡張構文のtest
(define (extended-cond-test clause)
  (car clause))
;; 拡張構文のrecipient
(define (extended-cond-recipient clause)
  (caddr clause))
;; (define (cond-actinos clause) (cdr clause))
;; cond-actions を修正
(define (cond-actions clause)
  (if (extended-cond? clause)
      (list (extended-cond-recipient clause)
            (extended-cond-test clause))
      (cdr clause)))
(define (cond->if exp)
  (expand-clauses (cond-clauses exp)))
(define (expand-clauses clauses)
  (if (null? clauses)
;;      false ; else節なし
      'false ; else節なし
      (let ((first (car clauses))
            (rest (cdr clauses)))
        (if (cond-else-clause? first)
            (if (null? rest)
                (sequence->exp (cond-actions first))
                (error "ELSEclause isn't last -- COND->IF" clauses))
            (make-if (cond-predicate first)
                     (sequence->exp (cond-actions first))
                     (expand-clauses rest))))))
;; 構文変換として実装するようにした(condのような)式を導出された式(derived expressions)という。letもまた導出された式である

;; eval-andの定義
(define (and? exp)
  (tagged-list? exp 'and))
(define (and-clauses exp) (cdr exp))
(define (eval-and exp env)
  (define (iter rest result)
    (if (null? rest)
        result
        (let ((first-eval (eval (car rest) env)))
          (if (true? first-eval)
              (iter (cdr rest) first-eval)
              false))))
  (iter (and-clauses exp) true))

;; eval-orの定義
(define (or? exp)
  (tagged-list? exp 'or))
(define (or-clauses exp) (cdr exp))
(define (eval-or exp env)
  (define (iter rest result)
    (if (null? rest)
        result
        (let ((first-eval (eval (car rest) env)))
          (if (true? first-eval)
              true
              (iter (cdr rest) first-eval)))))
  (iter (or-clauses exp) false))

;; let (let->lambda)
;; (define (let? exp)
;;   (tagged-list? exp 'let))
;; (define (let-parameters exp)
;;   (cadr exp))
;; (define (let-body exp)
;;   (cddr exp))
;; (define (let-variables exp)
;;   (map car (let-parameters exp)))
;; (define (let-expressions exp)
;;   (map cadr (let-parameters exp)))
;; (define (let->combination exp)
;;   (if (null? (let-parameters exp))
;;       '()
;;     (cons
;;      (make-lambda (let-variables exp) (let-body exp))
;;      (let-expressions exp))))
(define (let? exp)
  (tagged-list? exp 'let))
(define (named-let? exp)                ; 追加
  (and (let? exp)
       (not (pair? (cadr exp)))))
(define (let-parameters exp)            ; 修正
  (if (named-let? exp)
      (caddr exp)
      (cadr exp)))
(define (let-body exp)                  ; 修正
  (if (named-let? exp)
      (cdddr exp)
      (cddr exp)))
(define (let-variables exp)
  (map car (let-parameters exp)))
(define (let-expressions exp)
  (map cadr (let-parameters exp)))
(define (let-name exp)                  ; 追加
  (cadr exp))
(define (make-definition variable body) ; 追加
  (list 'define variable body))
(define (let->combination exp)          ; 修正
  (if (named-let? exp)
      (if (null? (let-parameters exp))
          '()
          (make-begin
           (list
            (make-definition (let-name exp)
                             (make-lambda (let-variables exp) (let-body exp)))
            (cons (let-name exp) (let-expressions exp)))))
      (if (null? (let-parameters exp))
          '()
          (cons
           (make-lambda (let-variables exp) (let-body exp))
           (let-expressions exp)))))

;; let* (let*->let)
(define (let*? exp)
  (tagged-list? exp 'let*))
(define (let*-parameters exp)
  (cadr exp))
(define (let*-body exp)
  (caddr exp))
(define (make-let parameters body)
  (cons 'let (list parameters body)))
(define (let*->nested-lets exp)
  (define (iter reverse-parameters result)
    (if (null? reverse-parameters)
        result
        (iter (cdr reverse-parameters)
              (make-let (list (car reverse-parameters)) result))))
  (iter (reverse (let*-parameters exp))
        (let*-body exp)))
;; letrec (letrec->let)
(define (letrec? exp)
  (tagged-list? exp 'letrec))
(define (letrec-parameters exp)
  (cadr exp))
(define (letrec-body exp)
  (cddr exp))
(define (letrec->let exp)
  (let ((vars
         (map (lambda (x) (list (car x) ''*unsigned*)) (letrec-parameters exp)))
        (vals
         (map (lambda (x) (list 'set! (car x) (cadr x))) (letrec-parameters exp)))
        (body (letrec-body exp)))
    (cons 'let
          (cons vars
                (append vals body)))))

;; while->named-let
(define (while? exp) (tagged-list? exp 'while))
(define (while-predicate exp) (cadr exp))
(define (while-body exp) (cddr exp))
(define (make-named-let name parameters body)
  (list 'let name parameters body))
(define (while->named-let exp)
  (make-named-let 'while-loop
                  '()
                  (make-if (while-predicate exp)
                           (make-begin
                            (list (car (while-body exp))
                                  '(while-loop)))
                           '())))
;; ---------------------------------------------
;; 述語のテスト
;; ---------------------------------------------
(define (true? x)
  (not (eq? x false)))
(define (false? x)
  (eq? x false))

;; ---------------------------------------------
;; 手続きの表現
;; ---------------------------------------------

;; 基本手続き
;; (apply-primitive-procedure <proc> <args>)
;; (primitive-procedure? <proc>)

;; 合成手続き
;; (define (make-procedure parameters body env)
;;   (list 'procedure parameters body env))
;; 4.16で変更
(define (make-procedure parameters body env)
  (list 'procedure parameters (scan-defines body) env))
(define (compound-procedure? p)
  (tagged-list? p 'procedure))
(define (procedure-parameters p) (cadr p))
(define (procedure-body p) (caddr p))
(define (procedure-environment p) (cadddr p))

;; ---------------------------------------------
;; 環境に対する操作
;; ---------------------------------------------
;; 環境をフレームのリストとして表現する。ある環境の外側の環境はリストのcdrである
;; 空の環境は単に環境のリストである
(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 (car frame)))
  (set-cdr! frame (cons val (cdr 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))))
;; 現在の環境から外側の環境へと変数を探していく。空の環境へ行き着いたらエラーとする
;; scan手続きはscan結果の戻り値をfalseにするとfalseが定義されていないエラーとなるし、nullにすると引数がnullな場合に引数が定義されていないエラーとなるため、使えない…
#|
(define (scan var vars vals proc)
  (cond ((null? vars) '())
        ((eq? var (car vars)) (proc vars vals))
        (else (scan var (cdr vars) (cdr vals) proc))))

(define (scan-env-loop var env proc)
  (if (eq? env the-empty-environment)
      '()
      (let ((frame (first-frame env)))
        (let ((bind-pair 
               (scan var (frame-variables frame) (frame-values frame) proc)))
          (if (null? bind-pair)
              (scan-env-loop var (enclosing-environment env) proc)
              bind-pair)))))

(define (lookup-variable-value var env)
  (let ((val (scan-env-loop var env
                            (lambda (vars vals) (car vals)))))
    (newline)
    (display " --- var [")
    (display var)
    (display "] --- null? [")
    (display (null? val))
    (display "] --- ")
    (newline)
    (if (null? val)
        (error "Unbound variable" var)
        val)))
|#
;; 変数へ新しい値を設定する
#|
(define (set-variable-value! var val env)
  (let ((val (scan-env-loop var env
                            (lambda (vars vals) (set-car! vals val) true))))
    (if (null? val)
        (error "Unbound variable -- SET!" var)
        val)))
|#
;; 新しい変数を定義する。最初のフレームに束縛されている変数を探し、存在すれば値を変更する。存在しなければ追加する
#|
(define (define-variable! var val env)
  (let ((frame (first-frame env)))
    (let ((result (scan var
                        (frame-variables frame)
                        (frame-values frame)
                        (lambda (vars vals) (set-car! vals val) true))))
      (if (null? result)
          (add-binding-to-frame! var val frame)))))
|#
;; unbind!
#|
(define (unbind-variable! var env)
  (let ((frame (first-frame env)))
    (let ((result (scan var
                        (frame-variables frame)
                        (frame-values frame)
                        (lambda (vars vals)
                          (set-car! vars (cdr vars))
                          (set-car! vals (cdr vals))
                          true))))
      (if (null? result)
          (error "Unbound variable --UNBIND!" var)))))
|#
;; 4.16で変更
#|
(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))
             (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))
|#
;; a. 値が*unassigned*ならエラーとするlookup-variable-value
(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))))
;; unbind!
(define (unbind-variable! var env)
  (let ((frame (first-frame env)))
    (define (scan vars vals)
      (cond ((null? vars)
             (error "Unbound variable -- UNBIND!" var))
            ((eq? var (car vars))
             (begin
               (set-car! vars (cdr vars))
               (set-car! vals (cdr vals))))
            (else (scan (cdr vars) (cdr vals)))))
    (scan (frame-variables frame)
          (frame-values frame))))
;; 4.16で追加
;; b. 手続き本体を取り、手続き中のdefineをlet, set!形式に変換を施す scan-out-defines
(define (make-assignment var val)
  (list 'set! var val))

(define (scan-defines proc-body)
  (define (definitions rest result)
    (if (null? rest)
        result
        (let ((exp (car rest)))
          (if (definition? exp)
              (definitions (cdr rest)
                           (append result
                                   (list (list (definition-variable exp)
                                               (definition-value exp)))))
              (definitions (cdr rest) result)))))
  (define (body-exps rest result)
    (if (null? rest)
        result
        (let ((exp (car rest)))
          (if (definition? exp)
              (body-exps (cdr rest) result)
              (body-exps (cdr rest) (append result (list exp)))))))
  (define (make-let-list var-val-list)
    (map (lambda (x) (list (car x) ''*unassigned*)) var-val-list))
  (define (make-assignment-list var-val-list)
    (map (lambda (x) (make-assignment (car x) (cadr x))) var-val-list))
  (define (make-let-iter assignment-list body-list result)
    (cond ((not (null? assignment-list))
           (make-let-iter (cdr assignment-list)
                          body-list
                          (append result (list (car assignment-list)))))
          ((not (null? body-list))
           (make-let-iter assignment-list
                          (cdr body-list)
                          (append result (list (car body-list)))))
          (else result)))
  (let ((definition-list (definitions proc-body '()))
        (body-list (body-exps proc-body '())))
    (if (null? definition-list)
        proc-body
        (let ((let-body (list 'let definition-list)))
          (list
           (make-let-iter (make-assignment-list definition-list)
                          body-list let-body))))))


;; ---------------------------------------------
;; 評価器の実行
;; ---------------------------------------------
;; 必要なものは基本手続きの作用をモデル化するために、基盤になるLispシステムを呼び出す機構を作ること
;; 一義的なオブジェクトを評価しようとしている式に現れ得る基本手続きの名前に対応付ける大域環境を設定する。大域環境にはまだ評価する式で変数として扱えるように記号trueとfalseの束縛もある
(define (setup-environment)
  (let ((initial-env
         (extend-environment (primitive-procedure-names)
                             (primitive-procedure-objects)
                             the-empty-environment)))
    (define-variable! 'true true initial-env)
    (define-variable! 'false false initial-env)
    initial-env))

;; 基本手続き
(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 'map map)
        ;; <基本手続きが続く>
        ))
(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))
;; 超循環評価器を走らせるのを便利にするため、基盤Lispシステムの読込み-評価-印字ループをモデル化する駆動ループ(driver loop)を用意する。これは促進記号(prompt)を印字し、入力式を読み込み、この式を大域環境で評価し、結果を印字する。印字された結果の前に出力記号(output prompt)をつけ、式の値を他の印字された出力から区別できるようにする
;; 4.2.2節で修正
;; (define input-prompt ";;; M-Eval input:")
;; (define output-prompt ";;; M-Eval value:")
(define input-prompt ";;; L-Eval input:")
(define output-prompt ";;; L-Eval value:")
(define (driver-loop)
  (prompt-for-input input-prompt)
  (let ((input (read)))
    ;; 4.2.2節で修正
    ;; (let ((output (eval input the-global-environment)))
    (let ((output
           (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))
;; 非常に長くなりそうな(または循環するかも知れない)合成手続きの環境部分を避けるため、特別な印字手続きuser-printを使う
(define (user-print object)
  (if (compound-procedure? object)
      (display (list 'compound-procedure
                     (procedure-parameters object)
                     (procedure-body object)
                     '<procedure-env>))
      (display object)))

;; 評価器を走らせるための駆動ループの起動
;; (define the-global-environment (setup-environment))
;; (driver-loop)

;; 4.2.2節で追加
;; メモ化していないthunkの表現
(define (force-it obj)
  (if (thunk? obj)
      (actual-value (thunk-exp obj) (thunk-env obj))
      obj))
(define (delay-it exp env)
  (list 'thunk exp env))
(define (thunk? obj)
  (tagged-list? obj 'thunk))
(define (thunk-exp thunk)
  (cadr thunk))
(define (thunk-env thunk)
  (caddr thunk))
;; 4.2.2節で追加
;; メモ化されたthunk
;; (define (evaluated-thunk? obj)
;;   (tagged-list? obj 'evaluated-thunk))
;; (define (thunk-value evaluated-thunk) 
;;   (cadr evaluated-thunk))
;; (define (force-it obj)
;;   (cond ((thunk? obj)
;;          (let ((result (actual-value
;;                         (thunk-exp obj)
;;                         (thunk-env obj))))
;;            (set-car! obj 'evaluated-thunk)
;;            (set-car! (cdr obj) result) ; expをその値で置き換える
;;            (set-cdr! (cdr obj)'())     ; 不要なenvを忘れる
;;            result))
;;         ((evaluated-thunk? obj)
;;          (thunk-value obj))
;;         (else obj)))