SICP 読み (193) 4.2.2 遅延評価の解釈系

ヤバい。実機確認が面倒になりつつある。とりあえず 9.29 なエントリででっち上げたソレを確認してみる事に。たぶん一発ツモはないはず。
と言いつつ昨晩試験の作成に着手するも、べろべろ状態で手が動かなくなる。朝イチでゲキレンジャーを見つつ作成再開。
で、

   ("4.29 (2)"
    (let ((env (extend-environment '(tmp) '(0) the-global-environment)))
      (eval '(define count 0) env)
      (eval '(define (id (x lazy)) (set! count (+ count 1)) x) env)
      (eval '(define (square (x lazy)) (* x x)) env)
      (assert-equal 100 (eval '(square (id 10)) env))
      (assert-equal 2 (eval 'count env))
      )
    )

みたいな試験を書いたら NG との事。どこでボケかましてるんだろ、と思いつつ荒れた F1 at 富士スピードウェイを見てる日曜午後ッス。
てーか、そんなに簡単にイク訳ゃないわな。とりあえずココが微妙。

        ((compound-procedure? procedure)
         (eval-sequence
          (procedure-body procedure)
          (extend-environment
           (make-parameters (procedure-parameters procedure))
           (list-of-delayed-args arguments env)
           (procedure-environment procedure))))

とココ。

(define (list-of-delayed-args exps env)
  (define (delay-or-eval exp env)
    (if (pair? exp)
	(if (eq? (cadr exp) 'lazy)
	    (lazy-it exp env)
	    (lazy-memo-it exp env))
	(actual-value exp env)))
  (if (no-operands? exps)
      '()
      (cons (delay-or-eval (first-operand exps) env)
	    (list-of-delayed-args (rest-operands exps) env))))

ちょっとごっちゃになってる感じ。ここは実引数を扱う手続きじゃねぇか。ここでヤるなら仮引数なリストも必要だなぁ。
で、上記手続きの試験ってどうなってるのか、と思い見てみると

  ("list-of-delayed-args"
   ("example"
    (let ((env (extend-environment '(a c)
				   '(1 2)
				   the-global-environment)))
      (let ((args (list-of-delayed-args '(a (b lazy) c (d lazy-memo)) 
					env)))
	(assert-equal 1 (car args))
	(assert-equal 'lazy (car (car (cdr args))))
	(assert-equal 2 (car (cddr args)))
	(assert-equal 'lazy-memo (car (car (cdddr args))))
	)
      )
    )

な、なんだこれは。見事に混同しているな。ってか相当酔ってたに違いない。とりあえず一連の手続きと試験を以下に。

(define apply-in-underlying-scheme apply)

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

(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))
       ((begin? exp)
        (eval-sequence (begin-action exp) env))
       ((cond? exp) (eval (cond->if exp) env))
       ((let? exp) (eval (let->combination exp) env))
       ((application? exp)
        (apply (actual-value (operator exp) env)
               (operands exp)
               env))
       (else
        (error "Unknown expression type -- EVAL" exp))))

(define (make-parameters l)
  (if (null? l)
      '()
      (cons (if (pair? (car l))
		(caar l)
		(car l))
	    (make-parameters (cdr l)))))

(define (list-of-delayed-args exps args env)
  (define (delay-or-eval exp arg env)
    (if (pair? arg)
	(if (eq? (cadr arg) 'lazy)
	    (lazy-it exp env)
	    (lazy-memo-it exp env))
	(actual-value exp env)))
  (if (no-operands? exps)
      '()
      (cons (delay-or-eval (first-operand exps) 
			   (first-operand args)
			   env)
	    (list-of-delayed-args (rest-operands exps) 
				  (rest-operands args)
				  env))))

(define (lazy-it exp env)
  (list 'lazy exp env))
(define (lazy-memo-it exp env)
  (list 'lazy-memo exp env))
(define (lazy? obj)
  (if (pair? obj)
      (eq? 'lazy (car obj))
      #f))
(define (lazy-memo? obj)
  (if (pair? obj)
      (eq? 'lazy-memo (car obj))
      #f))

(define (force-it obj)
  (cond ((lazy? obj)
	 (actual-value (thunk-exp obj) (thunk-env obj)))
	((lazy-memo? obj)
         (let ((result (actual-value
                        (thunk-exp obj)
                        (thunk-env obj))))
           (set-car! obj 'evaluated-thunk)
           (set-car! (cdr obj) result)  ; replace exp with its value
           (set-cdr! (cdr obj) '())     ; forget unneeded env
           result))
        ((evaluated-thunk? obj)
         (thunk-value obj))
        (else obj)))

(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 (actual-value exp env)
 (force-it (eval exp env)))

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

(define (thunk-value evaluated-thunk) (cadr evaluated-thunk))

(define (thunk-exp thunk) (cadr thunk))

(define (thunk-env thunk) (caddr thunk))

(define (list-of-values exps env)
 (if (no-operands? exps)
     '()
     (cons (eval (first-operand exps) env)
           (list-of-values (rest-operands 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))

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

(define (self-evaluating? exp)
 (cond ((number? exp) #t)
       ((string? exp) #t)
       (else #f)))

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

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

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

(define (begin? exp) (tagged-list? exp 'begin))
(define (begin-action 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))
           (make-if (cond-predicate first)
                    (if (equal? '=> (cadr first))
                        (list (caddr first) (cond-predicate first))
                        (sequence->exp (cond-actions first)))
                    (expand-clauses rest))))))

(define (let? exp)
 (tagged-list? exp 'let))
(define (let->combination exp)
 (if (symbol? (cadr exp))
     (list 'begin
           (list 'define
                 (cadr exp)
                 (make-lambda (map car (caddr exp)) (cdddr exp)))
           (list (cadr exp) (map cadr (caddr exp))))
     (append (list (make-lambda (map car (cadr exp)) (cddr exp)))
             (map cadr (cadr exp)))))

(define (let*->nested-let exp)
 (define (let*->nested-let-iter arg)
   (cond ((null? arg) (caddr exp))
         (else
          (list 'let (list (car arg)) (let*->nested-let-iter (cdr arg))))))
 (let*->nested-let-iter (cadr exp)))

(define (true? x)
 (not (eq? x #f)))
(define (false? x)
 (eq? x #f))

(define (make-procedure parameters body env)
 (list 'procedure parameters 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))
            (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 'eqv? eqv?)
       (list 'eq? eq?)
       (list 'equal? equal?)
       (list 'number? number?)
       (list 'complex? complex?)
       (list 'real? real?)
       (list 'rational? rational?)
       (list 'integer? integer?)
       (list '= =)
       (list '< <)
       (list '> >)
       (list '<= <=)
       (list '>= >=)
       (list 'zero? zero?)
       (list 'positive? positive?)
       (list 'negative? negative?)
       (list 'odd? odd?)
       (list 'even? even?)
       (list 'max max)
       (list 'min min)
       (list '+ +)
       (list '* *)
       (list '- -)
       (list '/ /)
       (list 'assoc assoc)
       (list 'cadr cadr)
       (list 'cddr cddr)
       (list 'caddr caddr)
       (list 'cdddr cdddr)
;        <more primitives>
       ))
(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 (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))

あと試験の一部を以下に。

  ("apply"
   ("define"
    (let ((env (extend-environment '(tmp) '(0) the-global-environment)))
      (let ((l '(define (f a (b lazy) c (d lazy-memo))
		  (+ a b c d))))
	(eval l env)
	(assert-equal 'procedure (car (eval 'f env)))
	(assert-equal '(a (b lazy) c (d lazy-memo)) (cadr (eval 'f env)))
	(assert-true (pair? (cadr (cadr (eval 'f env)))))
	(assert-true (eq? 'lazy (cadr (cadr (cadr (eval 'f env))))))
	(assert-true (pair? (cadddr (cadr (eval 'f env)))))
	(assert-true (eq? 'lazy-memo (cadr (cadddr (cadr (eval 'f env))))))
	)
      )
    )
   
   ("test ..."
    (let ((env (extend-environment '(tmp) '(0) the-global-environment)))
      (eval '(define (square x) (* x x)) env)
      (assert-equal 4 (eval '(square 2) env))
      (eval '(define (square2 (x lazy)) (* x x)) env)
      (assert-equal 4 (eval '(square2 2) env))
      (eval '(define (square3 (x lazy-memo)) (* x x)) env)
      (assert-equal 4 (eval '(square3 2) env))
      )
    )

   ("4.29 (1)"
    (let ((env (extend-environment '(tmp) '(0) the-global-environment)))
      (eval '(define count 0) env)
      (eval '(define (id x) (set! count (+ count 1)) x) env)
      (eval '(define (square x) (* x x)) env)
      (assert-equal 100 (eval '(square (id 10)) env))
      (assert-equal 1 (eval 'count env))
      )
    )

   ("4.29 (2)"
    (let ((env (extend-environment '(tmp) '(0) the-global-environment)))
      (eval '(define count 0) env)
      (eval '(define (id (x lazy)) (set! count (+ count 1)) x) env)
      (eval '(define (square (x lazy)) (* x x)) env)
      (assert-equal 100 (eval '(square (id 10)) env))
      (assert-equal 2 (eval 'count env))
      )
    )

   ("4.29 (3)"
    (let ((env (extend-environment '(tmp) '(0) the-global-environment)))
      (eval '(define count 0) env)
      (eval '(define (id (x lazy-memo)) (set! count (+ count 1)) x) env)
      (eval '(define (square (x lazy-memo)) (* x x)) env)
      (assert-equal 100 (eval '(square (id 10)) env))
      (assert-equal 1 (eval 'count env))
      )
    )
   )

  ("new force-it"
   ("pure"
    (let ((env (extend-environment '(tmp) '(0) the-global-environment)))
      (assert-equal 0 (force-it (eval 'tmp env)))
      )
    )

   ("lazy"
    (let ((env (extend-environment '(tmp) '(0) the-global-environment)))
      (let ((exp '(+ tmp 1)))
	(let ((test (lazy-it exp env)))
	  (assert-equal 'lazy (car test))
	  (assert-equal exp (cadr test))
	  (assert-equal env (caddr test))
	  (assert-equal 1 (force-it test))
	  )
	)
      )
    )

   ("lazy-memo"
    (let ((env (extend-environment '(tmp) '(0) the-global-environment)))
      (let ((exp '(+ tmp 1)))
	(let ((test (lazy-memo-it exp env)))
	  (assert-equal 'lazy-memo (car test))
	  (assert-equal exp (cadr test))
	  (assert-equal env (caddr test))
	  (assert-equal 1 (force-it test))
	  (assert-equal 'evaluated-thunk (car test))
	  (assert-equal 1 (force-it test))
	  )
	)
      )
    )
   )

  ("list-of-delayed-args"
   ("example"
    (let ((env (extend-environment '(a c)
				   '(1 2)
				   the-global-environment)))
      (let ((args (list-of-delayed-args '(a b c d)
					'(a (b lazy) c (d lazy-memo)) 
					env)))
	(assert-equal 1 (car args))
	(assert-equal 'lazy (car (car (cdr args))))
	(assert-equal 'b (cadr (car (cdr args))))
	(assert-equal 2 (car (cddr args)))
	(assert-equal 'lazy-memo (car (car (cdddr args))))
	(assert-equal 'd (cadr (car (cdddr args))))
	)
      )
    )
   )

  ("make-parameters"
   ("example"
    (assert-equal '(a b c d)
		  (make-parameters '(a (b lazy) c (d lazy-memo))))
    )
   )

  ("lazy-memo-it"
   ("list"
    (assert-equal 'lazy-memo (car (lazy-memo-it '(a b c)
						the-global-environment)))
    )
   )

  ("lazy-it"
   ("list"
    (assert-equal 'lazy (car (lazy-it '(a b c) the-global-environment)))
    )
   )

  ("lazy?"
   ("(b lazy-memo)"
    (assert-false (lazy? '(lazy-memo b)))
    )

   ("xxx"
    (assert-false (lazy? 'xxx))
    )

   ("(c lazy)"
    (assert-true (lazy? '(lazy c)))
    )
   )

  ("lazy-memo?"
   ("(b lazy-memo)"
    (assert-true (lazy-memo? '(lazy-memo b)))
    )

   ("xxx"
    (assert-false (lazy-memo? 'xxx))
    )

   ("(c lazy)"
    (assert-false (lazy-memo? '(lazy c)))
    )
   )

なんかまだバグってる雰囲気満点ですがこれで終わり (を

追記

て昨晩酔って force-it が駄目って書いてるのを今頃発見。何を考えてこんな事書いてるのかも不明ですが、エントリ入れた記憶が無いのはイカガなものか。