EOPL 第3章の Exercise 3.37 から 3.40

前回から1ヶ月も間があいてしまった。3.7節では変数への破壊的代入を取り扱えるようにする。

以前 OCaml で書いた Scheme もどき [1] でも代入をサポートしていたのだけど、それとはアプローチが違う。
[1] では環境のインターフェイスに直接代入のための操作を追加していたのに対して、ここでは環境から返ってくる値が参照になるようにして、その参照に対して deref や setref! を行う。
回りくどいようだけどインターフェイスにむやみに操作を追加するのはよくないということなんだろう。

練習問題 ～3.40 では begin を追加したり define を追加したりする。

define を追加する問題では「もし初期環境にすでに同名変数があった場合は代入、そうでなければ環境の拡張」という要件なので、これまでの環境のように見つからなかったらエラーで終了というわけにはいかなくなる。ここでは define-datatype で OCaml 風の option 型を定義してラップすることにした。

; Exercise 3.37..3.40
(load "r5rs.scm")
(load "define-datatype.scm")
(load "sllgen.scm")
(use srfi-1)

; Exercise 3.27 from p.101
(define newrefs
  (lambda (vals)
    (let ((vec (list->vector vals)))
      (map
        (lambda (x) (a-ref x vec))
        (iota (vector-length vec))))))

; reference

(define-datatype reference reference?
  (a-ref
    (position integer?)
    (vec vector?)))

(define primitive-deref
  (lambda (ref)
    (cases reference ref
      (a-ref (pos vec) (vector-ref vec pos)))))

(define primitive-setref!
  (lambda (ref val)
    (cases reference ref
      (a-ref (pos vec) (vector-set! vec pos val)))))

(define deref
  (lambda (ref)
    (primitive-deref ref)))

(define setref!
  (lambda (ref val)
    (primitive-setref! ref val)))

; option

(define-datatype option option?
  (none)
  (some (val scheme-value?)))

(define scheme-value? (lambda (x) #t))

(define assert-some
  (lambda (opt)
    (cases option opt
      (some (val) val)
      (none () (eopl:error 'assert-some "Expected some but found none")))))

; boolean

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

; environment

(define-datatype environment environment?
  (empty-env-record)
  (extended-env-record
    (syms (list-of symbol?))
    (vals vector?)
    (env environment?))
  )

(define empty-env
  (lambda ()
    (empty-env-record)))

(define extend-env
  (lambda (syms vals env)
    (extended-env-record syms (list->vector vals) env)))

(define extend-env-recursively
  (lambda (proc-names idss bodies old-env)
    (extended-env-record
      proc-names
      (list->vector
        (map
          (lambda (x) (closure x proc-names idss bodies old-env))
          (iota (length proc-names))))
      old-env)))

(define apply-env
  (lambda (env sym)
    (deref (assert-some (apply-env-ref env sym)))))

(define apply-env-ref
  (lambda (env sym)
    (cases environment env
      (empty-env-record () (none))
      (extended-env-record (syms vals env)
        (let ((pos (list-find-position sym syms)))
          (if (number? pos)
            (some (a-ref pos vals))
            (apply-env-ref env sym)))))))

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

; closure

(define-datatype procval procval?
  (closure
    (pos number?)
    (proc-names (list-of symbol?))
    (idss (list-of (list-of symbol?)))
    (bodies (list-of expression?))
    (env environment?)))

(define apply-procval
  (lambda (proc args)
    (cases procval proc
      (closure (pos proc-names idss bodies env)
        (eval-expression
          (list-ref bodies pos)
          (extend-env
            (list-ref idss pos)
            args
            (extend-env-recursively
              proc-names idss bodies env)))))))

; interpreter

(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 0 (list '_) (list ids) (list body) env))
      (app-exp (rator rands)
        (let ((proc (eval-expression rator env))
              (args (eval-rands rands env)))
          (if (procval? proc)
            (apply-procval proc args)
            (eopl:error 'eval-expression
              "Attempt to apply non-procedure ~s" proc))))
      (letrec-exp (proc-names idss bodies letrec-body)
        (eval-expression
          letrec-body
          (extend-env-recursively proc-names idss bodies env)))
      (varassign-exp (id rhs-exp)
        (begin
          (setref!
            (assert-some (apply-env-ref env id))
            (eval-expression rhs-exp env))
          1))
      ; Exercise 3.39 from p.103
      (begin-exp (exp exps)
        (last
          (map-in-order
            (lambda (x) (eval-expression x env))
            (cons exp exps))))
      )))

(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))
      (eq?-prim () (if (eq? (car args) (cadr args)) (true-value) (false-value)))
      )))

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

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

(define grammar-3.37
  '((form
      ("define" identifier "=" expression)
      def-form)
    (form
      (expression)
      exp-form)
    (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)
    (expression
      ("letrec"
       (arbno
         identifier "(" (separated-list identifier ",") ")" "=" expression)
       "in" expression)
      letrec-exp)
    (expression
      ("set" identifier "=" expression)
      varassign-exp)
    (expression
      ("begin" expression (arbno ";" expression) "end")
      begin-exp)
    (primitive ("+") add-prim)
    (primitive ("-") subtract-prim)
    (primitive ("*") mult-prim)
    (primitive ("add1") incr-prim)
    (primitive ("sub1") decr-prim)
    (primitive ("eq?") eq?-prim)
    (primitive ("globals") globals-prim)
    ))

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

(sllgen:make-define-datatypes scanner-spec-3.37 grammar-3.37)

(define read-eval-print
  (sllgen:make-rep-loop
    "-->"
    (let ((globals (init-env)))
      (lambda (f)
        (cases form f
          (def-form (sym exp)
            (let ((val (eval-expression exp globals)))
              (cases option (apply-env-ref globals sym)
                (some (ref)
                  (setref! ref val))
                (none ()
                  (set!
                    globals
                    (extend-env (list sym) (list val) globals))))
              (display "")))
          (exp-form (exp)
            (eval-expression exp globals)))))
    (sllgen:make-stream-parser
      scanner-spec-3.37
      grammar-3.37)))

練習問題 3.40 は最後に define を使って再帰関数 odd, even を作れともいっている。

でもこれまでの再帰じゃないほうの関数だとクロージャの環境はあくまで作成時の環境であって、define によって初期環境が拡張されても影響を受けないし、環境も「最後まで見つからなかったら大域変数のテーブルを見る」とかしているわけではないから（[1] ではそうしていた）、これではまだ足りないようだ。

特にもう一工夫せよという問題のようには見えないのだけど、とりあえず保留。

[1] http://blog.so-net.ne.jp/rainyday/2007-10-27