EOPL 第3章の Exercise 3.19 から 3.22: proc の追加

EOPL の続きでファーストクラスの関数の追加。プリミティブの適用とユーザ定義関数の適用が全然違う構文になるので気持ち悪いけど…

練習問題 3.20 は引数の数のチェック機能の追加。練習問題 3.21 と 3.22 は letrec を導入しなくてもここまでで作った言語で再帰が書けるよって話。このテクニックは面白いな。型付き言語だとどういう型にすればいいんだろう？

ちなみに私はいままで SLLGEN での文法定義と define-datatype による構文木のヴァリアント型定義は別個にしなければいけないと思っていて構文を追加するごとに2箇所（eval を入れて3箇所）に手を入れるのは面倒くさいと感じていたんだけど、実は sllgen:make-define-datatypes は define-datatype するところも自動でやってくれていたらしい。

; Exercise 3.19 .. 3.20
(load "r5rs.scm")
(load "define-datatype.scm")
(load "sllgen.scm")
(load "./2.eopl.scm") ; for extend-env, empty-env

(define true-value (lambda () 1))
(define false-value (lambda () 0))
(define true-value?
  (lambda (x)
    (not (= 0 x))))

(define closure
  (lambda (ids body env)
    (lambda (args)
      (if (= (length ids) (length args))
        (eval-expression body (extend-env ids args env))
        (eopl:error 'closure
                    "Wrong number of arguments: ~s required, but got ~s"
                    (length ids) (length args))))))

(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)))
      (if-exp (test-exp true-exp false-exp)
        (if (true-value? (eval-expression test-exp env))
          (eval-expression true-exp env)
          (eval-expression false-exp env)))
      (let-exp (ids rands body)
        (let ((args (eval-rands rands env)))
          (eval-expression body (extend-env ids args env))))
      (proc-exp (ids body)
        (closure ids body env))
      (app-exp (rator rands)
        (let ((proc (eval-expression rator env))
              (args (eval-rands rands env)))
          (apply-procval proc 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))
      )))

(define apply-procval
  (lambda (proc args)
    (proc args)))

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

(define scanner-spec-3-5
  '((white-sp
      (whitespace) skip)
    (comment
      ("%" (arbno (not #\newline))) skip)
    (identifier
      (letter (arbno (or letter digit "?"))) symbol)
    (number
      (digit (arbno digit)) number)))

(define grammar-3-5
  '((program
      (expression)
      a-program)
    (expression
      (number)
      lit-exp)
    (expression
      (identifier)
      var-exp)
    (expression
      (primitive "(" (separated-list expression ",") ")" )
      primapp-exp)
    (expression
      ("if" expression "then" expression "else" expression)
      if-exp)
    (expression
      ("let" (arbno identifier "=" expression) "in" expression)
      let-exp)
    (expression
      ("proc" "(" (separated-list identifier ",") ")" expression)
      proc-exp)
    (expression
      ("(" expression (arbno expression) ")")
      app-exp)
    (primitive ("+") add-prim)
    (primitive ("-") subtract-prim)
    (primitive ("*") mult-prim)
    (primitive ("add1") incr-prim)
    (primitive ("sub1") decr-prim)
    ))

(define scan&parse
  (sllgen:make-string-parser
    scanner-spec-3-5
    grammar-3-5))

(sllgen:make-define-datatypes scanner-spec-3-5 grammar-3-5)

(define run
  (lambda (string)
    (eval-program
      (scan&parse string))))

(define read-eval-print
  (sllgen:make-rep-loop "-->" eval-program
    (sllgen:make-stream-parser
      scanner-spec-3-5
      grammar-3-5)))

; Exercise 3.21
;
; let makefact = proc (maker, x)
;                  if x
;                  then *(x, (maker maker -(x, 1)))
;                  else 1
; in let fact = proc (n) (makefact makefact n)
;    in (fact 5)

; Exercise 3.22
;
; let makeodd =
;   proc (oddmaker, evenmaker, x)
;     if x
;     then (evenmaker oddmaker evenmaker -(x, 1))
;     else 0
; in let makeeven =
;   proc (oddmaker, evenmaker, x)
;     if x
;     then (oddmaker oddmaker evenmaker -(x, 1))
;     else 1
; in let odd = proc (n) (makeodd makeodd makeeven n)
; in let even = proc (n) (makeeven makeodd makeeven n)
;    in (odd 3)