EOPL 第3章の Exercise 3.48

"3.7 Variable Assignment" もようやく最後。

ここまでのインタプリタでは代入を Scheme のベクタの破壊的書き換えを使って実現してきました。これを Scheme の副作用に依存しない形に書き換えるのが練習問題 3.48 です。

このために store という「位置→値」の関数的なものを用意し、環境は「変数名→位置」に取って代わらせます。store は環境と同じでそのまま関数で実装しても良いでしょうが、ここでは define-datatype を使ってリスト状の構造を作りました。変数の書き換えは store を拡張することに相当し、eval 系の処理は store を追加引数にとって、戻り値として値のほかに新しい store を返すようにします。この戻り値のために answer というデータ型を定義します。

今日の解答はいつもより特に出来が悪い感じがするので公開するのがあまり気が進みません。リファクタリングできていない感が随所に漂うコードです。とりあえずやりましたということで。

(load "r5rs.scm")
(load "define-datatype.scm")
(load "sllgen.scm")
(use srfi-1)
;(require (lib "1.ss" "srfi"))

(define expval? (lambda (v) #t))

(define-datatype answer answer?
  (an-answer
    (val expval?)
    (store store?)))

; store

(define-datatype store store?
  (empty-store-record)
  (extended-store-record
    (location number?)
    (val expval?)
    (str store?)
  ))

(define empty-store (lambda () (empty-store-record)))

(define extend-store
  (lambda (location val store)
    (extended-store-record location val store)))

(define apply-store
  (lambda (str loc)
    (cases store str
      (empty-store-record ()
        (eopl:error 'apply-store "No store for location ~s" loc))
      (extended-store-record (loc2 val str)
        (if (= loc loc2)
          val
          (apply-store str loc)))
      )))

(define store-length
  (lambda (str)
    (cases store str
      (empty-store-record () 0)
      (extended-store-record (loc val str) (+ 1 (store-length str))))))

; 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 store)
    (let ((ans (make-closures proc-names idss bodies old-env store)))
      (cases answer ans
        (an-answer (locs new-store)
          (an-answer
            (extended-env-record
              proc-names
              (list->vector locs)
              old-env)
            new-store))))))

(define make-closures
  (lambda (proc-names idss bodies old-env store)
    (let
      ((ans
         (fold
           (lambda (x ans)
             (cases answer ans
               (an-answer (locs str)
                 (let ((new-location (store-length str)))
                   (an-answer
                     (cons new-location locs)
                     (extend-store
                       new-location
                       (closure x proc-names idss bodies old-env)
                       str))))))
           (an-answer '() store)
           (iota (length proc-names)))))
      (cases answer ans
        (an-answer (locs str)
          (an-answer (reverse locs) str))))))

(define apply-env
  (lambda (env sym)
    (cases environment env
      (empty-env-record ()
        (eopl:error 'apply-env "No binding for ~s" sym))
      (extended-env-record (syms vals env)
        (let ((pos (list-find-position sym syms)))
          (if (number? pos)
            (vector-ref vals pos)
            (apply-env 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))))))

(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 store)
    (cases procval proc
      (closure (pos proc-names idss bodies env)
        (cases answer (extend-env-recursively
                        proc-names idss bodies env store)
          (an-answer (new-env new-store)
            (eval-expression
              (list-ref bodies pos)
              (extend-env
                (list-ref idss pos)
                args
                new-env)
              new-store)))))))

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

(define eval-expression
  (lambda (exp env store)
    (cases expression exp
      (lit-exp (datum) (an-answer datum store))
      (var-exp (id)
        (an-answer
          (apply-store store (apply-env env id))
          store))
      (primapp-exp (prim rands)
        (cases answer (eval-rands rands env store)
          (an-answer (args new-store)
            (apply-primitive
              prim
              (map (lambda (x) (apply-store new-store x)) args)
              new-store))))
      (if-exp (test-exp true-exp false-exp)
        (cases answer (eval-expression test-exp env store)
          (an-answer (val new-store)
            (if (true-value? val)
              (eval-expression true-exp env new-store)
              (eval-expression false-exp env new-store)))))
      (let-exp (ids rands body)
        (cases answer (eval-rands rands env store)
          (an-answer (args new-store)
            (eval-expression body (extend-env ids args env) new-store))))
      (proc-exp (ids body)
        (an-answer
          (closure 0 (list '_) (list ids) (list body) env)
          store))
      (app-exp (rator rands)
        (cases answer (eval-expression rator env store)
          (an-answer (proc new-store1)
            (cases answer (eval-rands rands env new-store1)
              (an-answer (args new-store2)
                (if (procval? proc)
                  (apply-procval proc args new-store2)
                  (eopl:error 'eval-expression
                    "Attempt to apply non-procedure ~s" proc)))))))
      (letrec-exp (proc-names idss bodies letrec-body)
        (cases answer (extend-env-recursively
                        proc-names idss bodies env store)
          (an-answer (new-env new-store)
            (eval-expression
              letrec-body
              new-env
              new-store))))
      (varassign-exp (id rhs-exp)
        (cases answer (eval-expression rhs-exp env store)
          (an-answer (val new-store)
            (let ((c (apply-env env id)))
              (an-answer 1 (extend-store c val new-store))))))
      )))

(define eval-rands
  (lambda (rands env store)
    (let
      ((ans
        (fold
          (lambda (rand ans)
            (cases answer ans
              (an-answer (locs str)
                (cases answer (eval-rand rand env str)
                  (an-answer (val new-store)
                    (let ((new-location (store-length new-store)))
                      (an-answer
                        (cons new-location locs)
                        (extend-store new-location val new-store))))))))
          (an-answer '() store)
          rands)))
      (cases answer ans
        (an-answer (locs str)
          (an-answer (reverse locs) str))))))

(define eval-rand eval-expression)

(define apply-primitive
  (lambda (prim args store)
    (cases primitive prim
      (add-prim ()
        (an-answer (+ (car args) (cadr args)) store))
      (subtract-prim ()
        (an-answer (- (car args) (cadr args)) store))
      (mult-prim ()
        (an-answer (* (car args) (cadr args)) store))
      (incr-prim ()
        (an-answer (+ (car args) 1) store))
      (decr-prim ()
        (an-answer (- (car args) 1) store))
      (eq?-prim ()
        (an-answer
          (if (eq? (car args) (cadr args)) (true-value) (false-value))
          store))
      )))

(define init-env (lambda () (empty-env)))

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

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

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

(sllgen:make-define-datatypes scanner-spec-letrec-varassign
grammar-letrec-varassign)

(define run
  (lambda (string)
    (cases answer (eval-program (scan&parse string))
      (an-answer (val store)
        val))))

あと、この store 実装だと値を書き換えた後、古い値は単にシャドウイングされるだけなので変数を書き換えるたびに不要メモリが GC されずに増え続けることになると思います。

ところでこれで 3.7 までが一応終わったことになりますが、preface によるとこの本の内容の依存性として 1->2->3.1-3.7 までは一直線なんですが、このあとは 3.8, 3.9, 4.1, 5, 7 のいずれかに進んでいいことになっています。スーパーマリオでいうとワープの土管が並んでいるところですね。さてどうするか。