kariyayo/_SICPの問題等を解いていく_4章.md

## _SICPの問題等を解いていく_4章.md

      
    Raw
  

              _SICPの問題等を解いていく_4章.md
            
          
    SICPの問題等を解いていく


Guileを使う
rlwrapも使う
$ rlwrap -r -c guile こんな感じで使う

> ,q で終了する
> (load "foo.scm") でソースコード読み込む
> ,trace (f 3) で関数の適用をトレースする


1~3章はこちら

  
## sicp-4-evaluator-lazy.scm
;; 述語
(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) (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 (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))))
(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 apply-in-underlying-scheme apply) ; guileのapplyを退避させる

(define (primitive-procedure? proc)
  (tagged-list? proc 'primitive))
(define (primitive-implementation proc) (cadr proc))
(define (apply-primitive-procedure proc args)
  (apply-in-underlying-scheme (primitive-implementation proc) args))
(define primitive-procedures
  (list (list 'car car)
        (list 'cdr cdr)
        (list 'cadr cadr)
        (list 'cddr cddr)
        (list 'cons cons)
        (list 'null? null?)
        (list 'assoc assoc)
        (list '+ +)
        (list '- -)
        (list '* *)
        (list '/ /)
        (list '> >)
        (list '< <)
        (list '= =)
        ))
(define (primitive-procedure-names)
  (map car primitive-procedures))
(define (primitive-procedure-objects)
  (map (lambda (proc) (list 'primitive (cadr proc)))
       primitive-procedures))
(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 (tagged-list? exp tag)
  (if (pair? exp)
      (eq? (car exp) tag)
      #f))

;; 自己評価式
;; e.g. 1, "Hello World"
(define (self-evaluating? exp)
  (cond ((number? exp) #t)
        ((string? exp) #t)
        (else #f)))

;; 変数
;; e.g. x, y
(define (variable? exp) (symbol? exp))

;; クォート式
;; e.g. (quote foo)
(define (quoted? exp) (tagged-list? exp 'quote))
(define (text-of-quotation exp) (cadr exp))

;; 代入
;; e.g. (set! x 10)
(define (assignment? exp) (tagged-list? exp 'set!))
(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))

;; 定義
;; e.g. (define x 11), (define (double x) (* x x))
(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式
;; e.g. (lambda (x) (* x x))
(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)))

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

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

;; 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? (cddr exp)))
      (cadddr exp)
      #f))
(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))


;;; 派生式
;; 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 (cond-actions clause) (cdr clause))
(define (cond->if exp) (expand-clauses (cond-clauses exp)))
(define (expand-clauses clauses)
  (if (null? clauses)
      #f
      (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))
            (make-if (cond-predicate first)
                     (if (eq? (car (cond-actions first)) '=>)
                         (list (cadr (cond-actions first)) (cond-predicate first))
                         (sequence->exp (cond-actions first)))
                     (expand-clauses rest))))))

;; let
(define (let? exp) (tagged-list? exp 'let))
(define (let-args exp)
  (let ((bindings (cadr exp)))
    (map car bindings)))
(define (let-exps exp)
  (let ((bindings (cadr exp)))
    (map cadr bindings)))
(define (let-body exp) (cddr exp))

(define (named-let-args exp)
  (let ((bindings (caddr exp)))
    (map car bindings)))
(define (named-let-exps exp)
  (let ((bindings (caddr exp)))
    (map cdr bindings)))
(define (named-let-body exp) (cadddr exp))

(define (let->combination exp)
  (if (symbol? (cadr exp))
      (let ((f-name (cadr exp)))
        (make-begin
          (list
            (list 'define (cons f-name (named-let-args exp))
                  (named-let-body exp))
            (cons f-name (named-let-exps exp)))))
      (cons (make-lambda (let-args exp) (let-body exp))
              (let-exps exp))))

;; let*
(define (let*? exp) (tagged-list? exp 'let*))
(define (let*-body exp) (cddr exp))
(define (let*->nested-lets exp)
  (define (iter varexps)
    (if (null? varexps)
        (let*-body exp)
        (list 'let (list (car varexps)) (iter (cdr varexps)))))
  (iter (cadr exp)))

;; 内部定義
(define (scan-out-defines exp)
  (define (has-define? exp)
    (if (null? exp)
        #f
        (if (definition? (car exp))
            #t
            (has-define? (cdr exp)))))
  (define (body exp)
    (if (tagged-list? (car exp) 'define)
        (body (cdr exp))
        exp))
  (define (iter exp acc)
    (if (tagged-list? (car exp) 'define)
        (iter (cdr exp)
              (cons (cons (cons (definition-variable (car exp)) (cons ''*unassigned* `())) (car acc))
                    (cons (list 'set! (definition-variable (car exp)) (definition-value (car exp))) (cdr acc))))
        (cons (reverse (car acc)) (reverse (cdr acc)))))
  (if (has-define? exp)
      (let ((varexps-sets (iter exp (cons `() `()))))
        (list (cons 'let (cons (car varexps-sets) (append (cdr varexps-sets) (body exp))))))
      exp))


;;;;;;;;;;
;;; サンクの表現

(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))

(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)))

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

(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))))

;;;;;;;;;;
;;; 評価手続き

(define (list-of-values exps env)
  (define (first-operand exps) (car exps))
  (if (no-operands? exps)
      `()
      (let ((first (eval (first-operand exps) env)))
        (cons first (list-of-values (rest-operands exps) env)))))

(define (eval-and exps env)
  (if (false? (actual-value (first-exp exps) env))
      #f
      (if (last-exp? exps)
          #t
          (eval-and (rest-exps exps) env))))

(define (eval-or exps env)
  (if (true? (actual-value (first-exp exps) env))
      #t
      (if (last-exp? exps)
          #f
          (eval-or (rest-exps exps) env))))

(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 (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-delayed-args arguments env)
                                             (procedure-environment procedure))))
        (else (error "Unknown procedure type: APPLY" procedure))))


;; 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))
        ((definition? exp) (eval-definition exp env))
        ((and? exp) (eval-and (and-exps exp) env))
        ((or? exp) (eval-or (or-exps exp) env))
        ((if? exp) (eval-if exp env))
        ((lambda? exp) (make-procedure (lambda-parameters exp)
                                       (lambda-body exp)
                                       env))
        ((begin? exp) (eval-sequence (begin-actions exp) env))
        ((cond? exp) (eval (cond->if exp) env))
        ((let? exp) (eval (let->combination exp) env))
        ((let*? exp) (eval (let*->nested-lets exp) env))
        ((application? exp)
          (apply (actual-value (operator exp) env)
                 (operands exp)
                 env))
        (else (error "Unknown expression type: EVAL" exp))
  ))


;;;;;;;;;;
;;; ドライバループ
(define the-global-environment (setup-environment))

(define input-prompt  ";;; L-Eval input:")
(define output-prompt ";;; L-Eval value:")
(define (driver-loop)
  (prompt-for-input input-prompt)
  (let ((input (read)))
    (let ((output (actual-value input the-global-environment)))
      (announce-output output-prompt)
      (user-print output)))
  (driver-loop))
(define (prompt-for-input string)
  (newline) (display string) (newline))
(define (announce-output string)
  (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)))


## sicp-4-evaluator.scm
;; 述語
(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) (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 (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))))
(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 apply-in-underlying-scheme apply) ; guileのapplyを退避させる

(define (primitive-procedure? proc)
  (tagged-list? proc 'primitive))
(define (primitive-implementation proc) (cadr proc))
(define (apply-primitive-procedure proc args)
  (apply-in-underlying-scheme (primitive-implementation proc) args))
(define primitive-procedures
  (list (list 'car car)
        (list 'cdr cdr)
        (list 'cadr cadr)
        (list 'cddr cddr)
        (list 'cons cons)
        (list 'null? null?)
        (list 'assoc assoc)
        (list '+ +)
        (list '- -)
        (list '* *)
        (list '/ /)
        (list '> >)
        (list '< <)
        (list '= =)
        ))
(define (primitive-procedure-names)
  (map car primitive-procedures))
(define (primitive-procedure-objects)
  (map (lambda (proc) (list 'primitive (cadr proc)))
       primitive-procedures))
(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 (tagged-list? exp tag)
  (if (pair? exp)
      (eq? (car exp) tag)
      #f))

;; 自己評価式
;; e.g. 1, "Hello World"
(define (self-evaluating? exp)
  (cond ((number? exp) #t)
        ((string? exp) #t)
        (else #f)))

;; 変数
;; e.g. x, y
(define (variable? exp) (symbol? exp))

;; クォート式
;; e.g. (quote foo)
(define (quoted? exp) (tagged-list? exp 'quote))
(define (text-of-quotation exp) (cadr exp))

;; 代入
;; e.g. (set! x 10)
(define (assignment? exp) (tagged-list? exp 'set!))
(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))

;; 定義
;; e.g. (define x 11), (define (double x) (* x x))
(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式
;; e.g. (lambda (x) (* x x))
(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)))

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

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

;; 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? (cddr exp)))
      (cadddr exp)
      #f))
(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))


;;; 派生式
;; 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 (cond-actions clause) (cdr clause))
(define (cond->if exp) (expand-clauses (cond-clauses exp)))
(define (expand-clauses clauses)
  (if (null? clauses)
      #f
      (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))
            (make-if (cond-predicate first)
                     (if (eq? (car (cond-actions first)) '=>)
                         (list (cadr (cond-actions first)) (cond-predicate first))
                         (sequence->exp (cond-actions first)))
                     (expand-clauses rest))))))

;; let
(define (let? exp) (tagged-list? exp 'let))
(define (let-args exp)
  (let ((bindings (cadr exp)))
    (map car bindings)))
(define (let-exps exp)
  (let ((bindings (cadr exp)))
    (map cadr bindings)))
(define (let-body exp) (cddr exp))

(define (named-let-args exp)
  (let ((bindings (caddr exp)))
    (map car bindings)))
(define (named-let-exps exp)
  (let ((bindings (caddr exp)))
    (map cdr bindings)))
(define (named-let-body exp) (cadddr exp))

(define (let->combination exp)
  (if (symbol? (cadr exp))
      (let ((f-name (cadr exp)))
        (make-begin
          (list
            (list 'define (cons f-name (named-let-args exp))
                  (named-let-body exp))
            (cons f-name (named-let-exps exp)))))
      (begin
        (newline)
        (display (cons (make-lambda (let-args exp) (let-body exp)) (let-exps exp)))
        (newline)
        (cons (make-lambda (let-args exp) (let-body exp))
              (let-exps exp)))))

;; let*
(define (let*? exp) (tagged-list? exp 'let*))
(define (let*-body exp) (cddr exp))
(define (let*->nested-lets exp)
  (define (iter varexps)
    (if (null? varexps)
        (let*-body exp)
        (list 'let (list (car varexps)) (iter (cdr varexps)))))
  (iter (cadr exp)))

;; 内部定義
(define (scan-out-defines exp)
  (define (has-define? exp)
    (if (null? exp)
        #f
        (if (definition? (car exp))
            #t
            (has-define? (cdr exp)))))
  (define (body exp)
    (if (tagged-list? (car exp) 'define)
        (body (cdr exp))
        exp))
  (define (iter exp acc)
    (if (tagged-list? (car exp) 'define)
        (iter (cdr exp)
              (cons (cons (cons (definition-variable (car exp)) (cons ''*unassigned* `())) (car acc))
                    (cons (list 'set! (definition-variable (car exp)) (definition-value (car exp))) (cdr acc))))
        (cons (reverse (car acc)) (reverse (cdr acc)))))
  (if (has-define? exp)
      (let ((varexps-sets (iter exp (cons `() `()))))
        (newline)
        (display (list (cons 'let (cons (car varexps-sets) (append (cdr varexps-sets) (body exp) )))))
        (newline)
        (list (cons 'let (cons (car varexps-sets) (append (cdr varexps-sets) (body exp))))))
      exp))


;;;;;;;;;;
;;; 評価手続き

(define (list-of-values exps env)
  (define (first-operand exps) (car exps))
  (if (no-operands? exps)
      `()
      (let ((first (eval (first-operand exps) env)))
        (cons first (list-of-values (rest-operands exps) env)))))

(define (eval-and exps env)
  (if (false? (eval (first-exp exps) env))
      #f
      (if (last-exp? exps)
          #t
          (eval-and (rest-exps exps) env))))

(define (eval-or exps env)
  (if (true? (eval (first-exp exps) env))
      #t
      (if (last-exp? exps)
          #f
          (eval-or (rest-exps exps) env))))

(define (eval-if exp env)
  (if (true? (eval (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 (apply procedure arguments)
  (cond ((primitive-procedure? procedure) (apply-primitive-procedure procedure arguments))
        ((compound-procedure? procedure)
          (eval-sequence (procedure-body procedure)
                         (extend-environment (procedure-parameters procedure)
                                             arguments
                                             (procedure-environment procedure))))
        (else error "Unknown procedure type: APPLY" procedure)
  ))


;; 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))
        ((definition? exp) (eval-definition exp env))
        ((and? exp) (eval-and (and-exps exp) env))
        ((or? exp) (eval-or (or-exps exp) env))
        ((if? exp) (eval-if exp env))
        ((lambda? exp) (make-procedure (lambda-parameters exp)
                                       (lambda-body exp)
                                       env))
        ((begin? exp) (eval-sequence (begin-actions exp) env))
        ((cond? exp) (eval (cond->if exp) env))
        ((let? exp) (eval (let->combination exp) env))
        ((let*? exp) (eval (let*->nested-lets exp) env))
        ((application? exp) (apply (eval (operator exp) env) (list-of-values (operands exp) env)))
        (else (error "Unknown expression type: EVAL" exp))
  ))


;;;;;;;;;;
;;; ドライバループ

(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 (eval input the-global-environment)))
      (announce-output output-prompt)
      (user-print output)))
  (driver-loop))
(define (prompt-for-input string)
  (newline) (display string) (newline))
(define (announce-output string)
  (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)))

## sicp-4_01.scm
;;; sicp-4-evaluator.scmをベースとする


;; 被演算子を左から評価
(define (list-of-values exps env)
  (define (first-operand exps) (car exps))
  (if (no-operands? exps)
      `()
      (let ((first (eval (first-operand exps) env)))
        (cons first (list-of-values (rest-operands exps) env)))))
;; scheme@(guile-user)> (driver-loop)
;;
;; ;;; M-Eval input:
;; (- 10 2)
;; ;;; M-Eval value:
;; 8


;; 被演算子を右から評価
(define (list-of-values exps env)
  (define (first-operand exps) (car exps))
  (define (loop exps args)
    (if (no-operands? exps)
        args
        (let ((first (eval (first-operand exps) env)))
          (loop (rest-operands exps) (cons first args)))))
  (loop exps `()))

;; scheme@(guile-user)> (driver-loop)
;;
;; ;;; M-Eval input:
;; (- 10 2)
;; ;;; M-Eval value:
;; -8

## sicp-4_02.scm
;; evalの先頭に手続き適用を持ってくると...
;; (define (eval exp env)
;;  (cond ((application? exp) (apply (eval (operator exp) env) (list-of-values (operands exp) env)))
;;        ...

;; scheme@(guile-user)> (driver-loop)
;;
;; ;;; M-Eval input:
;; (+ 1 2)
;; ;;; M-Eval value:
;; 3
;; ;;; M-Eval input:
;; (define x 3)    ; `Unbound variable define` が出力される
;; ice-9/boot-9.scm:1669:16: In procedure raise-exception:
;; Unbound variable define


;; 以下のように書き換えると...
(define (application? exp) (tagged-list? exp 'call))
(define (operator exp) (cadr exp))
(define (operands exp) (cddr exp))

;; scheme@(guile-user)> (driver-loop)
;;
;; ;;; M-Eval input:
;; (call + 1 2)    ; 手続き適用にcallを使う
;; ;;; M-Eval value:
;; 3
;; ;;; M-Eval input:
;; (define x 3)    ; defineも大丈夫
;; ;;; M-Eval value:
;; ok
;; ;;; M-Eval input:
;; (+ 1 2)    ; callなしだと評価できなくなる
;; ice-9/boot-9.scm:1669:16: In procedure raise-exception:
;; Unknown expression type: EVAL (+ 1 2)

## sicp-4_04.scm
(define (eval exp env)
  (cond ((self-evaluating? exp) exp)
        ...
        ((and? exp) (eval-and (and-exps exp) env))
        ((or? exp) (eval-or (or-exps exp) env))
        ...

(define (and? exp) (tagged-list? exp 'and))
(define (and-exps exp) (cdr exp))
(define (or? exp) (tagged-list? exp 'or))
(define (or-exps exp) (cdr exp))

(define (eval-and exps env)
  (if (false? (eval (first-exp exps) env))
      #f
      (if (last-exp? exps)
          #t
          (eval-and (rest-exps exps) env))))
(define (eval-or exps env)
  (if (true? (eval (first-exp exps) env))
      #t
      (if (last-exp? exps)
          #f
          (eval-or (rest-exps exps) env))))

;; scheme@(guile-user)> (driver-loop)
;;
;; ;;; M-Eval input:
;; (if (and (> 3 2) (= 4 4)) 'yes 'no)
;; ;;; M-Eval value:
;; yes
;; ;;; M-Eval input:
;; (if (and (> 3 2) (= 2 4)) 'yes 'no)
;; ;;; M-Eval value:
;; no
;; ;;; M-Eval input:
;; (if (or (> 3 2) (= 2 4)) 'yes 'no)
;; ;;; M-Eval value:
;; yes
;; ;;; M-Eval input:
;; (if (and (or (= 2 4) (> 3 2)) (= 1 0)) 'yes 'no)
;; ;;; M-Eval value:
;; no

## sicp-4_05.scm
(define (expand-clauses clauses)
  (if (null? clauses)
      #f
      (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))
            (make-if (cond-predicate first)
                     (if (eq? (car (cond-actions first)) '=>)
                         (list (cadr (cond-actions first)) (cond-predicate first))
                         (sequence->exp (cond-actions first)))
                     (expand-clauses rest))))))

;; ;;; M-Eval input:
;; (cond ((assoc 'b '((a 1) (b 2))) => cadr)
;;       (else false))
;; ;;; M-Eval value:
;; 2

## sicp-4_06.scm
(define (eval exp env)
  (cond ((self-evaluating? exp) exp)
        ...
        ((let? exp) (eval (let->combination exp) env))
        ...


;; let
;; letは派生式なので別の式（lambda式）に変換するだけでいい
(define (let? exp) (tagged-list? exp 'let))
(define (let-args exp)
  (let ((varexps (cadr exp)))
    (map car varexps)))
(define (let-exps exp)
  (let ((varexps (cadr exp)))
    (map cdr varexps)))
(define (let-body exp) (cddr exp))
(define (let->combination exp)
  (list (make-lambda (let-args exp) (let-body exp))
        (let-exps exp)))

;; scheme@(guile-user)> (driver-loop)
;;
;; ;;; M-Eval input:
;; (define (adder initial)
;;   (let ((acc initial))
;;     (lambda (x)
;;       (set! acc (+ acc x))
;;       acc
;;     )))
;; ;;; M-Eval value:
;; ok
;; ;;; M-Eval input:
;; (define f (adder 0))
;; ;;; M-Eval value:
;; ok
;; ;;; M-Eval input:
;; (f 1)
;; ;;; M-Eval value:
;; 1
;; ;;; M-Eval input:
;; (f 2)
;; ;;; M-Eval value:
;; 3
;; ;;; M-Eval input:

## sicp-4_07.scm
(define (eval exp env)
  (cond ((self-evaluating? exp) exp)
        ...
        ((let? exp) (eval (let->combination exp) env))
        ...


;; let*
;; 入れ子のletに変換
(define (let*? exp) (tagged-list? exp 'let*))
(define (let*-body exp) (cddr exp))
(define (let*->nested-lets exp)
  (define (iter varexps)
    (if (null? varexps)
        (let*-body exp)
        (list 'let (list (car varexps)) (iter (cdr varexps)))))
  (iter (cadr exp)))

;; scheme@(guile-user)> (driver-loop)
;;
;; ;;; M-Eval input:
;; (let* ((x 3) (y (+ x 2)) (z (+ x y 5)))
;;   (* x z))
;; ;;; M-Eval value:
;; 39

## sicp-4_08.scm
(define (named-let-args exp)
  (let ((bindings (caddr exp)))
    (map car bindings)))
(define (named-let-exps exp)
  (let ((bindings (caddr exp)))
    (map cdr bindings)))
(define (named-let-body exp) (cadddr exp))

(define (let->combination exp)
  (if (symbol? (cadr exp))
      (let ((f-name (cadr exp)))
        (make-begin
          (list
            (list 'define (cons f-name (named-let-args exp))
                  (named-let-body exp))
            (cons f-name (named-let-exps exp)))))
      (list (make-lambda (let-args exp) (let-body exp))
            (let-exps exp))));; ;; M-Eval input:

;; (define (fib n)
;;   (let fib-iter ((a 1)
;;                  (b 0)
;;                  (count n))
;;     (if (= count 0)
;;         b
;;         (fib-iter (+ a b) a (- count 1)))))
;; ;;; M-Eval value:
;; ok
;; ;;; M-Eval input:
;; (fib 10)
;; ;;; M-Eval value:
;; 55

## sicp-4_16.scm
(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 (scan-out-defines exp)
  (define (has-define? exp)
    (if (null? exp)
        #f
        (if (definition? (car exp))
            #t
            (has-define? (cdr exp)))))
  (define (body exp)
    (if (tagged-list? (car exp) 'define)
        (body (cdr exp))
        exp))
  (define (iter exp acc)
    (if (tagged-list? (car exp) 'define)
        (iter (cdr exp)
              (cons (cons (cons (definition-variable (car exp)) (cons ''*unassigned* `())) (car acc))
                    (cons (list 'set! (definition-variable (car exp)) (definition-value (car exp))) (cdr acc))))
        (cons (reverse (car acc)) (reverse (cdr acc)))))
  (if (has-define? exp)
      (let ((varexps-sets (iter exp (cons `() `()))))
        (newline)
        (display (list (cons 'let (cons (car varexps-sets) (append (cdr varexps-sets) (body exp) )))))
        (newline)
        (list (cons 'let (cons (car varexps-sets) (append (cdr varexps-sets) (body exp))))))
      exp))


(define (make-procedure parameters body env)
  (list 'procedure parameters (scan-out-defines body) env))


;; cf. 問題4.16 – SICP（計算機プログラムの構造と解釈）その188 : Serendip – Webデザイン・プログラミング https://www.serendip.ws/archives/1973
;;
;;
;; scheme@(guile-user)> (driver-loop)
;;
;; ;;; M-Eval input:
;; (define foo (lambda (x) (define a 1) (define b 2) (* (+ a x) b)))
;;
;; ((let ((a (quote *unassigned*)) (b (quote *unassigned*))) (set! a 1) (set! b 2) (* (+ a x) b)))
;; ;;; M-Eval value:
;; ok
;; ;;; M-Eval input:
;; (foo 7)
;;
;; ((lambda (a b) (set! a 1) (set! b 2) (* (+ a x) b)) (quote *unassigned*) (quote *unassigned*))
;; ;;; M-Eval value:
;; 16
;;
;;
;; ;;; M-Eval input:
;; (define (f x)
;;   (define (even? n)
;;     (if (= n 0)
;;         true
;;         (odd? (- n 1))))
;;   (define (odd? n)
;;     (if (= n 0)
;;         false
;;         (even? (- n 1))))
;;   (cond ((even? x) 'even)
;;         ((odd? x) 'odd)))
;;
;; ((let ((even? (quote *unassigned*)) (odd? (quote *unassigned*))) (set! even? (lambda (n) (if (= n 0) true (odd? (- n 1))))) (set! odd? (lambda (n) (if (= n 0) false (even? (- n 1))))) (cond ((even? x) (quote even)) ((odd? x) (quote odd)))))
;; ;;; M-Eval value:
;; ok
;; ;;; M-Eval input:
;; (f 5)
;;
;; ((lambda (even? odd?) (set! even? (lambda (n) (if (= n 0) true (odd? (- n 1))))) (set! odd? (lambda (n) (if (= n 0) false (even? (- n 1))))) (cond ((even? x) (quote even)) ((odd? x) (quote odd)))) (quote *unassigned*) (quote *unassigned*))
;; ;;; M-Eval value:
;; odd
;; ;;; M-Eval input:
;; (f 6)
;;
;; ((lambda (even? odd?) (set! even? (lambda (n) (if (= n 0) true (odd? (- n 1))))) (set! odd? (lambda (n) (if (= n 0) false (even? (- n 1))))) (cond ((even? x) (quote even)) ((odd? x) (quote odd)))) (quote *unassigned*) (quote *unassigned*))
;; ;;; M-Eval value:
;; even

## sicp-4_22.scm
;;; ここまでsicp-4-evaluator.scmと同じ

;;;;;;;;;;
;;; 評価手続き
;;; ↓の解析手続きの置き換わる

;;;;;;;;;;
;;; 解析手続き
(define (analyze-self-evaluating exp)
  (lambda (env) exp))

(define (analyze-quoted exp)
  (let ((qval (text-of-quotation exp)))
    (lambda (env) qval)))

(define (analyze-variable exp)
  (lambda (env) (lookup-variable-value exp env)))

(define (analyze-assignment exp)
  (let ((var (assignment-variable exp))
        (vproc (analyze (assignment-value exp))))
    (lambda (env)
      (set-variable-value! var (vproc env) env)
      'ok)))

(define (analyze-definition exp)
  (let ((var (definition-variable exp))
        (vproc (analyze (definition-value exp))))
    (lambda (env)
      (define-variable! var (vproc env) env)
      'ok)))

(define (analyze-if exp)
  (let ((pproc (analyze (if-predicate exp)))
        (cproc (analyze (if-consequent exp)))
        (aproc (analyze (if-alternative exp))))
    (lambda (env) (if (true? (pproc env))
                      (cproc env)
                      (aproc env)))))

(define (analyze-lambda exp)
  (let ((vars (lambda-parameters exp))
        (bproc (analyze-sequence (lambda-body exp))))
    (lambda (env) (make-procedure vars bproc env))))

(define (analyze-sequence exps)
  (define (sequentially proc1 proc2)
    (lambda (env) (proc1 env) (proc2 env)))
  (define (loop first-proc rest-procs)
    (if (null? rest-procs)
        first-proc
        (loop (sequentially first-proc (car rest-procs))
              (cdr rest-procs))))
  (let ((procs (map analyze exps)))
    (if (null? procs) (error "Empty sequence: ANALYZE"))
    (loop (car procs) (cdr procs))))

(define (analyze-application exp)
  (let ((fproc (analyze (operator exp)))
        (aprocs (map analyze (operands exp))))
    (lambda (env)
      (execute-application
        (fproc env)
        (map (lambda (aproc) (aproc env)) aprocs)))))
(define (execute-application proc args)
  (cond ((primitive-procedure? proc) (apply-primitive-procedure proc args))
        ((compound-procedure? proc)
          ((procedure-body proc) (extend-environment (procedure-parameters proc)
                                                     args
                                                     (procedure-environment proc))))
        (else (error "Unknown procedure type: EXECUTE-APPLICATION" proc))))

(define (analyze exp)
  ;; ここで場合わけしているので、新たな式の型が増えた場合に追加する必要がある
  (cond ((self-evaluating? exp) (analyze-self-evaluating exp))
        ((quoted? exp) (analyze-quoted exp))
        ((variable? exp) (analyze-variable exp))
        ((assignment? exp) (analyze-assignment exp))
        ((definition? exp) (analyze-definition exp))
        ((if? exp) (analyze-if exp))
        ((lambda? exp) (analyze-lambda exp))
        ((begin? exp) (analyze-sequence (begin-actions exp)))
        ((cond? exp) (analyze (cond->if exp)))
        ((let? exp) (analyze (let->combination exp)))
        ((application? exp) (analyze-application exp))
        (else (error "Unknown expression type: ANALYZE" exp))
  ))

;; eval
(define (eval exp env) ((analyze exp) env))

;;;;;;;;;;
;;; ドライバループ

(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 (eval input the-global-environment)))
      (announce-output output-prompt)
      (user-print output)))
  (driver-loop))
(define (prompt-for-input string)
  (newline) (display string) (newline))
(define (announce-output string)
  (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)))


;; scheme@(guile-user)> (driver-loop)
;;
;; ;;; M-Eval input:
;; (define (f x)
;;   (let ((double (* x x)))
;;     (+ double 10)))
;; ;;; M-Eval value:
;; ok
;; ;;; M-Eval input:
;; (f 10)
;; ;;; M-Eval value:
;; 110

## sicp-4_26.scm
(define (analyze exp)
  (cond ((self-evaluating? exp) (analyze-self-evaluating exp))
  ...
  ((unless? exp) (analyze (unless->if exp)))
  ...


;; unless
(define (unless? exp) (tagged-list? exp 'unless))
(define (unless-predicate exp) (cadr exp))
(define (unless-consequent exp) (caddr exp))
(define (unless-alternative exp)
  (if (not (null? (cddr exp)))
      (cadddr exp)
      #f))
(define (unless->if exp)
  (make-if (unless-predicate exp)
           (unless-alternative exp)
           (unless-consequent exp)))

;; scheme@(guile-user)> (driver-loop)
;;
;; ;;; M-Eval input:
;; (unless (> 21 20) 'a 'b)
;; ;;; M-Eval value:
;; b
	;; 述語
	(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) (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 (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))))
	(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 apply-in-underlying-scheme apply) ; guileのapplyを退避させる

	(define (primitive-procedure? proc)
	(tagged-list? proc 'primitive))
	(define (primitive-implementation proc) (cadr proc))
	(define (apply-primitive-procedure proc args)
	(apply-in-underlying-scheme (primitive-implementation proc) args))
	(define primitive-procedures
	(list (list 'car car)
	(list 'cdr cdr)
	(list 'cadr cadr)
	(list 'cddr cddr)
	(list 'cons cons)
	(list 'null? null?)
	(list 'assoc assoc)
	(list '+ +)
	(list '- -)
	(list '* *)
	(list '/ /)
	(list '> >)
	(list '< <)
	(list '= =)
	))
	(define (primitive-procedure-names)
	(map car primitive-procedures))
	(define (primitive-procedure-objects)
	(map (lambda (proc) (list 'primitive (cadr proc)))
	primitive-procedures))
	(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 (tagged-list? exp tag)
	(if (pair? exp)
	(eq? (car exp) tag)
	#f))

	;; 自己評価式
	;; e.g. 1, "Hello World"
	(define (self-evaluating? exp)
	(cond ((number? exp) #t)
	((string? exp) #t)
	(else #f)))

	;; 変数
	;; e.g. x, y
	(define (variable? exp) (symbol? exp))

	;; クォート式
	;; e.g. (quote foo)
	(define (quoted? exp) (tagged-list? exp 'quote))
	(define (text-of-quotation exp) (cadr exp))

	;; 代入
	;; e.g. (set! x 10)
	(define (assignment? exp) (tagged-list? exp 'set!))
	(define (assignment-variable exp) (cadr exp))
	(define (assignment-value exp) (caddr exp))

	;; 定義
	;; e.g. (define x 11), (define (double x) (* x x))
	(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式
	;; e.g. (lambda (x) (* x x))
	(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)))

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

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

	;; 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? (cddr exp)))
	(cadddr exp)
	#f))
	(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))


	;;; 派生式
	;; 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 (cond-actions clause) (cdr clause))
	(define (cond->if exp) (expand-clauses (cond-clauses exp)))
	(define (expand-clauses clauses)
	(if (null? clauses)
	#f
	(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))
	(make-if (cond-predicate first)
	(if (eq? (car (cond-actions first)) '=>)
	(list (cadr (cond-actions first)) (cond-predicate first))
	(sequence->exp (cond-actions first)))
	(expand-clauses rest))))))

	;; let
	(define (let? exp) (tagged-list? exp 'let))
	(define (let-args exp)
	(let ((bindings (cadr exp)))
	(map car bindings)))
	(define (let-exps exp)
	(let ((bindings (cadr exp)))
	(map cadr bindings)))
	(define (let-body exp) (cddr exp))

	(define (named-let-args exp)
	(let ((bindings (caddr exp)))
	(map car bindings)))
	(define (named-let-exps exp)
	(let ((bindings (caddr exp)))
	(map cdr bindings)))
	(define (named-let-body exp) (cadddr exp))

	(define (let->combination exp)
	(if (symbol? (cadr exp))
	(let ((f-name (cadr exp)))
	(make-begin
	(list
	(list 'define (cons f-name (named-let-args exp))
	(named-let-body exp))
	(cons f-name (named-let-exps exp)))))
	(cons (make-lambda (let-args exp) (let-body exp))
	(let-exps exp))))

	;; let*
	(define (let? exp) (tagged-list? exp 'let))
	(define (let*-body exp) (cddr exp))
	(define (let*->nested-lets exp)
	(define (iter varexps)
	(if (null? varexps)
	(let*-body exp)
	(list 'let (list (car varexps)) (iter (cdr varexps)))))
	(iter (cadr exp)))

	;; 内部定義
	(define (scan-out-defines exp)
	(define (has-define? exp)
	(if (null? exp)
	#f
	(if (definition? (car exp))
	#t
	(has-define? (cdr exp)))))
	(define (body exp)
	(if (tagged-list? (car exp) 'define)
	(body (cdr exp))
	exp))
	(define (iter exp acc)
	(if (tagged-list? (car exp) 'define)
	(iter (cdr exp)
	(cons (cons (cons (definition-variable (car exp)) (cons ''unassigned `())) (car acc))
	(cons (list 'set! (definition-variable (car exp)) (definition-value (car exp))) (cdr acc))))
	(cons (reverse (car acc)) (reverse (cdr acc)))))
	(if (has-define? exp)
	(let ((varexps-sets (iter exp (cons `() `()))))
	(list (cons 'let (cons (car varexps-sets) (append (cdr varexps-sets) (body exp))))))
	exp))


	;;;;;;;;;;
	;;; サンクの表現

	(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))

	(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)))

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

	(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))))

	;;;;;;;;;;
	;;; 評価手続き

	(define (list-of-values exps env)
	(define (first-operand exps) (car exps))
	(if (no-operands? exps)
	`()
	(let ((first (eval (first-operand exps) env)))
	(cons first (list-of-values (rest-operands exps) env)))))

	(define (eval-and exps env)
	(if (false? (actual-value (first-exp exps) env))
	#f
	(if (last-exp? exps)
	#t
	(eval-and (rest-exps exps) env))))

	(define (eval-or exps env)
	(if (true? (actual-value (first-exp exps) env))
	#t
	(if (last-exp? exps)
	#f
	(eval-or (rest-exps exps) env))))

	(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 (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-delayed-args arguments env)
	(procedure-environment procedure))))
	(else (error "Unknown procedure type: APPLY" procedure))))


	;; 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))
	((definition? exp) (eval-definition exp env))
	((and? exp) (eval-and (and-exps exp) env))
	((or? exp) (eval-or (or-exps exp) env))
	((if? exp) (eval-if exp env))
	((lambda? exp) (make-procedure (lambda-parameters exp)
	(lambda-body exp)
	env))
	((begin? exp) (eval-sequence (begin-actions exp) env))
	((cond? exp) (eval (cond->if exp) env))
	((let? exp) (eval (let->combination exp) env))
	((let? exp) (eval (let->nested-lets exp) env))
	((application? exp)
	(apply (actual-value (operator exp) env)
	(operands exp)
	env))
	(else (error "Unknown expression type: EVAL" exp))
	))


	;;;;;;;;;;
	;;; ドライバループ
	(define the-global-environment (setup-environment))

	(define input-prompt ";;; L-Eval input:")
	(define output-prompt ";;; L-Eval value:")
	(define (driver-loop)
	(prompt-for-input input-prompt)
	(let ((input (read)))
	(let ((output (actual-value input the-global-environment)))
	(announce-output output-prompt)
	(user-print output)))
	(driver-loop))
	(define (prompt-for-input string)
	(newline) (display string) (newline))
	(define (announce-output string)
	(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)))
	;;; sicp-4-evaluator.scmをベースとする


	;; 被演算子を左から評価
	(define (list-of-values exps env)
	(define (first-operand exps) (car exps))
	(if (no-operands? exps)
	`()
	(let ((first (eval (first-operand exps) env)))
	(cons first (list-of-values (rest-operands exps) env)))))
	;; scheme@(guile-user)> (driver-loop)
	;;
	;; ;;; M-Eval input:
	;; (- 10 2)
	;; ;;; M-Eval value:
	;; 8


	;; 被演算子を右から評価
	(define (list-of-values exps env)
	(define (first-operand exps) (car exps))
	(define (loop exps args)
	(if (no-operands? exps)
	args
	(let ((first (eval (first-operand exps) env)))
	(loop (rest-operands exps) (cons first args)))))
	(loop exps `()))

	;; scheme@(guile-user)> (driver-loop)
	;;
	;; ;;; M-Eval input:
	;; (- 10 2)
	;; ;;; M-Eval value:
	;; -8
	;; evalの先頭に手続き適用を持ってくると...
	;; (define (eval exp env)
	;; (cond ((application? exp) (apply (eval (operator exp) env) (list-of-values (operands exp) env)))
	;; ...

	;; scheme@(guile-user)> (driver-loop)
	;;
	;; ;;; M-Eval input:
	;; (+ 1 2)
	;; ;;; M-Eval value:
	;; 3
	;; ;;; M-Eval input:
	;; (define x 3) ; `Unbound variable define` が出力される
	;; ice-9/boot-9.scm:1669:16: In procedure raise-exception:
	;; Unbound variable define


	;; 以下のように書き換えると...
	(define (application? exp) (tagged-list? exp 'call))
	(define (operator exp) (cadr exp))
	(define (operands exp) (cddr exp))

	;; scheme@(guile-user)> (driver-loop)
	;;
	;; ;;; M-Eval input:
	;; (call + 1 2) ; 手続き適用にcallを使う
	;; ;;; M-Eval value:
	;; 3
	;; ;;; M-Eval input:
	;; (define x 3) ; defineも大丈夫
	;; ;;; M-Eval value:
	;; ok
	;; ;;; M-Eval input:
	;; (+ 1 2) ; callなしだと評価できなくなる
	;; ice-9/boot-9.scm:1669:16: In procedure raise-exception:
	;; Unknown expression type: EVAL (+ 1 2)
	;;; ここまでsicp-4-evaluator.scmと同じ

	;;;;;;;;;;
	;;; 評価手続き
	;;; ↓の解析手続きの置き換わる

	;;;;;;;;;;
	;;; 解析手続き
	(define (analyze-self-evaluating exp)
	(lambda (env) exp))

	(define (analyze-quoted exp)
	(let ((qval (text-of-quotation exp)))
	(lambda (env) qval)))

	(define (analyze-variable exp)
	(lambda (env) (lookup-variable-value exp env)))

	(define (analyze-assignment exp)
	(let ((var (assignment-variable exp))
	(vproc (analyze (assignment-value exp))))
	(lambda (env)
	(set-variable-value! var (vproc env) env)
	'ok)))

	(define (analyze-definition exp)
	(let ((var (definition-variable exp))
	(vproc (analyze (definition-value exp))))
	(lambda (env)
	(define-variable! var (vproc env) env)
	'ok)))

	(define (analyze-if exp)
	(let ((pproc (analyze (if-predicate exp)))
	(cproc (analyze (if-consequent exp)))
	(aproc (analyze (if-alternative exp))))
	(lambda (env) (if (true? (pproc env))
	(cproc env)
	(aproc env)))))

	(define (analyze-lambda exp)
	(let ((vars (lambda-parameters exp))
	(bproc (analyze-sequence (lambda-body exp))))
	(lambda (env) (make-procedure vars bproc env))))

	(define (analyze-sequence exps)
	(define (sequentially proc1 proc2)
	(lambda (env) (proc1 env) (proc2 env)))
	(define (loop first-proc rest-procs)
	(if (null? rest-procs)
	first-proc
	(loop (sequentially first-proc (car rest-procs))
	(cdr rest-procs))))
	(let ((procs (map analyze exps)))
	(if (null? procs) (error "Empty sequence: ANALYZE"))
	(loop (car procs) (cdr procs))))

	(define (analyze-application exp)
	(let ((fproc (analyze (operator exp)))
	(aprocs (map analyze (operands exp))))
	(lambda (env)
	(execute-application
	(fproc env)
	(map (lambda (aproc) (aproc env)) aprocs)))))
	(define (execute-application proc args)
	(cond ((primitive-procedure? proc) (apply-primitive-procedure proc args))
	((compound-procedure? proc)
	((procedure-body proc) (extend-environment (procedure-parameters proc)
	args
	(procedure-environment proc))))
	(else (error "Unknown procedure type: EXECUTE-APPLICATION" proc))))

	(define (analyze exp)
	;; ここで場合わけしているので、新たな式の型が増えた場合に追加する必要がある
	(cond ((self-evaluating? exp) (analyze-self-evaluating exp))
	((quoted? exp) (analyze-quoted exp))
	((variable? exp) (analyze-variable exp))
	((assignment? exp) (analyze-assignment exp))
	((definition? exp) (analyze-definition exp))
	((if? exp) (analyze-if exp))
	((lambda? exp) (analyze-lambda exp))
	((begin? exp) (analyze-sequence (begin-actions exp)))
	((cond? exp) (analyze (cond->if exp)))
	((let? exp) (analyze (let->combination exp)))
	((application? exp) (analyze-application exp))
	(else (error "Unknown expression type: ANALYZE" exp))
	))

	;; eval
	(define (eval exp env) ((analyze exp) env))

	;;;;;;;;;;
	;;; ドライバループ

	(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 (eval input the-global-environment)))
	(announce-output output-prompt)
	(user-print output)))
	(driver-loop))
	(define (prompt-for-input string)
	(newline) (display string) (newline))
	(define (announce-output string)
	(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)))




	;; scheme@(guile-user)> (driver-loop)
	;;
	;; ;;; M-Eval input:
	;; (define (f x)
	;; (let ((double (* x x)))
	;; (+ double 10)))
	;; ;;; M-Eval value:
	;; ok
	;; ;;; M-Eval input:
	;; (f 10)
	;; ;;; M-Eval value:
	;; 110
	(define (analyze exp)
	(cond ((self-evaluating? exp) (analyze-self-evaluating exp))
	...
	((unless? exp) (analyze (unless->if exp)))
	...


	;; unless
	(define (unless? exp) (tagged-list? exp 'unless))
	(define (unless-predicate exp) (cadr exp))
	(define (unless-consequent exp) (caddr exp))
	(define (unless-alternative exp)
	(if (not (null? (cddr exp)))
	(cadddr exp)
	#f))
	(define (unless->if exp)
	(make-if (unless-predicate exp)
	(unless-alternative exp)
	(unless-consequent exp)))

	;; scheme@(guile-user)> (driver-loop)
	;;
	;; ;;; M-Eval input:
	;; (unless (> 21 20) 'a 'b)
	;; ;;; M-Eval value:
	;; b