EoPL reading (144) 3.2 The Front End

試験を書きかけて判明。emptylist を定義してない。

(use gauche.test)

(add-load-path ".")
(load "parse-program")
(load "Fig3.2")
(load "run")

(test-start "Ex.3.7")
(test-section "example")
(test* "(run '(list 1 2 3))"
       '(1 2 3)
       (run '(list 1 2 3)))

(test* "(run '(car (cons 4 emptylist)))"
       4
       (run '(car (cons 4 emptylist))))

(test-end)

しかも試験に通らない。

$ make
Testing parse-program ...                                        passed.
Testing Ex.3.6 ...                                               passed.
Testing Ex.3.7 ...                                               failed.
discrepancies found.  Errors are:
test (run '(list 1 2 3)): expects (1 2 3) => got ((1 2 3))
test (run '(car (cons 4 emptylist))): expects 4 => got #<error "apply-env \"No binding for ~s\" emptylist">
Testing Fig3.2 ...                                               passed.
Testing parse-program ...                                        passed.
Testing run ...                                                  passed.
$

うーん。微妙、って言いつつソース確認。
まず、list が微妙。

;;	   (list-prim () (list args))
	   (list-prim () args)

上記で正常動作。あと、emptylist が解決できない件は init-env に盛り込み。

(define init-env
  (lambda ()
    (extend-env
;;     '(i v x)
;;     '(1 5 10)
     '(i v x emptylist)
     '(1 5 10 '())
     (empty-env))))

もう少し試験追加の必要あり。現実トウヒ終了。

帰宅後

散歩しつつ emptylist 変数じゃなくて手続きにもできるな、という事に気づく。これは一旦置いといて試験を追加。

(use gauche.test)

(add-load-path ".")
(load "parse-program")
(load "Fig3.2")
(load "run")

(test-start "Ex.3.7")
(test-section "example")
(test* "(run '(list 1 2 3))"
       '(1 2 3)
       (run '(list 1 2 3)))

(test* "(run '(car (cons 4 emptylist)))"
       4
       (run '(car (cons 4 emptylist))))

(test-section "list, cons, car, cdr")
(test* "(run '(cdr (list 1 2 3)))"
       '(2 3)
       (run '(cdr (list 1 2 3))))

(test* "(run '(car (list 1 2 3)))"
       '1
       (run '(car (list 1 2 3))))

(test* "(run '(car (cons 1 2)))"
       '1
       (run '(car (cons 1 2))))

(test* "(run '(cdr (cons 1 2)))"
       '2
       (run '(cdr (cons 1 2))))

(test* "(run '(cons 1 (cons 2 emptylist)))"
       '(1 2)
       (run '(cons 1 (cons 2 emptylist))))

(test-end)

最後のがパスしない。

Testing Ex.3.7 ...                                               failed.
discrepancies found.  Errors are:
test (run '(cons 1 (cons 2 emptylist))): expects (1 2) => got (1 2 quote ())

これはやはり primitive な手続きにした方が良い模様。と言いつつ quote してるのが悪いのか。こうすれば試験パス。

(define init-env
  (lambda ()
    (extend-env
     '(i v x emptylist)
     '(1 5 10 ())
     (empty-env))))

emptylist は variable ってなってるのでこの実装で良い模様。以下に実装を列挙しときます。試験は略で。

  • Fig2.3.scm
(define eopl:error error)

(define empty-env
  (lambda ()
    (lambda (sym)
      (eopl:error 'apply-env "No binding for ~s" sym))))

(define extend-env
  (lambda (syms vals env)
    (lambda (sym)
      (let ((pos (list-find-position sym syms)))
	(if (number? pos)
	    (list-ref vals pos)
	    (apply-env env sym))))))

(define apply-env
  (lambda (env sym)
    (env sym)))

(define has-association?
  (lambda (env sym)
    (guard (e (else #f))
	   (env sym)
	   #t)))

(define list-find-position
  (lambda (sym los)
    (list-index (lambda (sym1) (eqv? sym1 sym)) los)))

(define list-index
  (lambda (pred ls)
    (cond ((null? ls) #f)
	  ((pred (car ls)) 0)
	  (else
	   (let ((list-index-r (list-index pred (cdr ls))))
	     (if (number? list-index-r)
		 (+ list-index-r 1)
		 #f))))))
  • Fig3.2.scm
(add-load-path ".")
(load "define-datatype")
(load "simple-interpreter")
(load "Fig2.3")

(define eval-program
  (lambda (pgm)
    (cases program pgm
	   (a-program (body)
		      (eval-expression body (init-env))))))

(define eval-expression
  (lambda (exp env)
    (cases expression exp
	   (lit-exp (datum) datum)
	   (var-exp (id) (apply-env env id))
	   (primapp-exp (prim rands)
			(let ((args (eval-rands rands env)))
			  (apply-primitive prim args))))))

(define eval-rands
  (lambda (rands env)
    (map (lambda (x) (eval-rand x env)) rands)))

(define eval-rand
  (lambda (rand env)
    (eval-expression rand env)))

(define apply-primitive
  (lambda (prim args)
    (cases primitive prim
	   (add-prim () (+ (car args) (cadr args)))
	   (subtract-prim () (- (car args) (cadr args)))
	   (mult-prim () (* (car args) (cadr args)))
	   (incr-prim () (+ (car args) 1))
	   (decr-prim () (- (car args) 1))
	   (print-prim () (print (car args)) 1)
	   (minus-prim () (- (car args)))
	   (list-prim () args)
	   (cons-prim () (cons (car args) (cadr args)))
	   (car-prim () (car (car args)))
	   (cdr-prim () (cdr (car args)))
	   )))

(define init-env
  (lambda ()
    (extend-env
     '(i v x emptylist)
     '(1 5 10 ())
     (empty-env))))
  • parse-program.scm
(define parse-program
  (lambda (datum)
    (list 'a-program (parse-expression datum))))

(define parse-expression
  (lambda (datum)
    (cond ((number? datum) (list 'lit-exp datum))
	  ((symbol? datum) (list 'var-exp datum))
	  ((pair? datum) 
	   (list 'primapp-exp
		 (list (cond ((eq? '+ (car datum)) 'add-prim)
			     ((eq? '- (car datum)) 'subtract-prim)
			     ((eq? '* (car datum)) 'mult-prim)
			     ((eq? 'add1 (car datum)) 'incr-prim)
			     ((eq? 'sub1 (car datum)) 'decr-prim)
			     ((eq? 'print (car datum)) 'print-prim)
			     ((eq? 'minus (car datum)) 'minus-prim)
			     ((eq? 'list (car datum)) 'list-prim)
			     ((eq? 'cons (car datum)) 'cons-prim)
			     ((eq? 'car (car datum)) 'car-prim)
			     ((eq? 'cdr (car datum)) 'cdr-prim)
		       ))
		 (map (lambda (x) (parse-expression x)) (cdr datum)))))))
  • run.scm
(add-load-path ".")
(load "parse-program")
(load "Fig3.2")

(define run
  (lambda (x)
    (eval-program (parse-program x))))
(add-load-path ".")
(load "define-datatype")

(define list-of
  (lambda (pred)
    (lambda (val)
      (or (null? val)
          (and (pair? val)
               (pred (car val))
               ((list-of pred) (cdr val)))))))

(define-datatype program program?
  (a-program
   (exp expression?)))

(define-datatype expression expression?
  (lit-exp
   (datum number?))
  (var-exp
   (id symbol?))
  (primapp-exp
   (prim primitive?)
   (rands (list-of expression?))))

(define-datatype primitive primitive?
  (add-prim)
  (subtract-prim)
  (mult-prim)
  (incr-prim)
  (decr-prim)
  (print-prim)
  (minus-prim)
  (list-prim)
  (cons-prim)
  (car-prim)
  (cdr-prim)
  )

なんか色々ありますね。。