EoPL reading (76) 2.2 An Abstraction for Inductive Data Type

差分が少ししかない、という事にてどうしたものか、と。

	   (var-exp (id)
		    (let free-symbol ((l arg) (s id))
		      (cond ((null? l)
			     (append rslt (list s)))
			    ((eq? (car l) s) rslt)
			    (else
			     (free-symbol (cdr l) s)))))

これ、呼び出し元はこんなカンジで

	   (var-exp (id)
                    (append rslt
                            (free-symbol arg id id '())))

free-symbol の定義が以下？

(define free-symbol
  (lambda (l s ret1 ret2)
    (cond ((null? l) ret1)
          ((eq? (car l) s) ret2)
	  (else
            (free-symbol (cdr l) s ret1 ret2)))))

なんか微妙。もすこしスマートなヤリ方があるような気もしますが、とりあえずこれで実装してみる事に。って memq って手続きがあるじゃん、という事で free-vars.scm の手続き定義を以下にしたんですが

(add-load-path ".")
(load "define-datatype")
(load "expression")
(load "parse")

(define (free-vars l)
  (free-vars-test (parse-expression l)))

(define (free-vars-test l)
  (let f ((rslt '()) (arg '()) (l l))
    (cases expression l
	   (nul-exp (datum) rslt)
	   (lit-exp (num) rslt)
	   (var-exp (id)
		    (if (memq id arg)
			rslt
			(append rslt (list id))))
	   (lambda-exp (ids body)
		       (f rslt (append arg ids) body))
	   (app-exp (rands)
		    (let app-exp-inner ((rslt rslt) (rands rands))
		      (if (null? rands)
			  rslt
			  (app-exp-inner (f rslt arg (car rands))
					 (cdr rands)))))
	   )))

cases に if-exp の記述が無い、と叱られました。else とかつけとくんじゃなかった。うーん、これは困った。ってか、こんなバグが入ってたとは。試験も書いてないし。。。
困った挙句にこんな実装でナニ。

(add-load-path ".")
(load "define-datatype")
(load "expression")
(load "parse")

(define (free-vars l)
  (free-vars-test (parse-expression l)))

(define (free-vars-test l)
  (let f ((rslt '()) (arg '()) (l l))
    (cases expression l
	   (nul-exp (datum) rslt)
	   (lit-exp (num) rslt)
	   (var-exp (id)
		    (if (memq id arg)
			rslt
			(append rslt (list id))))
	   (if-exp (test-exp true-exp false-exp)
		   (let ((rslt1 (f rslt arg test-exp)))
		     (let ((rslt2 (f rslt1 arg true-exp)))
		       (f rslt2 arg false-exp))))
	   (lambda-exp (ids body)
		       (f rslt (append arg ids) body))
	   (app-exp (rands)
		    (let app-exp-inner ((rslt rslt) (rands rands))
		      (if (null? rands)
			  rslt
			  (app-exp-inner (f rslt arg (car rands))
					 (cdr rands)))))
	   )))

微妙。試験にはパスしてますが、if が入った試験を書いてない。
ので、以下の試験を追加してみたんですが

(test* "(if ((lambda (x) x) y) ((lambda (x y) (+ x y)) z z) x) returns (y + z x)"
       '(y + z x)
       (free-vars '(if ((lambda (x) x) y) ((lambda (x y) (+ x y)) z z) x)))

試験にパスしない。

discrepancies found.  Errors are:
test (if ((lambda (x) x) y) ((lambda (x y) (+ x y)) z z) x) returns (y + z x): expects (y + z x) => got (y + z z x)

げげげ。z z って何だ。む、これって var-exp な処理が微妙なのか。こんなカンジで試験にパス。

	   (var-exp (id)
		    (if (memq id arg)
			rslt
;;			(if (or (not (null? rslt))
			(if (or (null? rslt)
				(not (memq id rslt)))
			    (append rslt (list id))
			    rslt)))

最初勘違いしてたのがコメントアウトな行から分かりますでしょうか。（とほほ
上記は free-vars.scm ですが bound-vars.scm が以下になります。

(add-load-path ".")
(load "define-datatype")
(load "expression")
(load "parse")

(define (bound-vars l)
  (bound-vars-test (parse-expression l)))

(define (bound-vars-test l)
  (let f ((rslt '()) (arg '()) (l l))
    (cases expression l
	   (nul-exp (datum) rslt)
	   (lit-exp (num) rslt)
	   (var-exp (id)
		    (if (memq id arg)
			(if (or (null? rslt)
				(not (memq id rslt)))
			    (append rslt (list id))
			    rslt)
			rslt))
	   (if-exp (test-exp true-exp false-exp)
		   (let ((rslt1 (f rslt arg test-exp)))
		     (let ((rslt2 (f rslt1 arg true-exp)))
		       (f rslt2 arg false-exp))))
	   (lambda-exp (ids body)
		       (f rslt (append arg ids) body))
	   (app-exp (rands)
		    (let app-exp-inner ((rslt rslt) (rands rands))
		      (if (null? rands)
			  rslt
			  (app-exp-inner (f rslt arg (car rands))
					 (cdr rands)))))
	   )))

横着せずに全部引用。結局抽象化ではなくってバグ探しになってしまったのは秘密。