EOPL 第3章の Exercise 3.46

練習問題 3.46 は代入が可能な処理系でフラットな環境のクロージャ実装を行う。代入無しだとただ環境を作り直すだけでよかったんだけど代入を許す言語だと代入する先が変わってしまうわけで、そこをどうにかしないといけないというところがポイント。

練習問題 3.27 でやったような実装だと、例えば、

let x = 0 in
let f = proc () set x = add1(x) in
let d = (f) in x

というコードが 1 でなく 0 になってしまう。

これを解決するために rib に入る値を最初からリファレンスにした。結構な手術になった。

(load "r5rs.scm")
(load "define-datatype.scm")
(load "sllgen.scm")
(use srfi-1)

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

; 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)
            (a-ref 0 (vector (closure
              x
              proc-names
              idss
              bodies
              (save-env
                proc-names
                (list-ref idss x)
                (list-ref bodies x)
                old-env)))))
          (iota (length proc-names))))
      old-env)))

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

; free vars

(define free-vars
  (letrec ((fv (lambda (vars exp)
                 (cases expression exp
                   (lit-exp (datum) '())
                   (var-exp (id)
                     (if (memv id vars) '() (list id)))
                   (primapp-exp (prim rands)
                     (fold
                       (lambda (x y) (lset-union eqv? x y))
                       '()
                       (map (lambda (x) (fv vars x)) rands)))
                   (if-exp (test-exp true-exp false-exp)
                     (lset-union
                       eqv?
                       (fv vars test-exp)
                       (fv vars true-exp)
                       (fv vars false-exp)))
                   (let-exp (ids rands body)
                     (fv (lset-union eqv? ids vars) body))
                   (proc-exp (ids body)
                     (fv (lset-union eqv? ids vars) body))
                   (app-exp (rator rands)
                     (fold
                       (lambda (x y) (lset-union eqv? x y))
                       '()
                       (map (lambda (x) (fv vars x)) (cons rator rands))))
                   (letrec-exp (proc-names idss bodies letrec-body)
                     (lset-union
                       eqv?
                       (let ((idss-bodies (zip idss bodies)))
                         (fold
                           lset-union
                           '()
                           (map
                             (lambda (ids-body)
                               (fv (lset-union eqv? (car ids-body) proc-names)
                                   (cadr ids-body)))
                             idss-bodies)))
                       (fv (lset-union eqv? proc-names vars) letrec-body)))
                   (varassign-exp (id rhs-exp)
                     (lset-union
                       eqv?
                       (if (memv id vars) '() (list id))
                       (fv vars rhs-exp)))
                   ))))
    (lambda (exp)
      (fv '() exp))))

(define set-diff
  (lambda (set1 set2)
    (lset-difference eqv? set1 set2)))

(define save-env
  (lambda (proc-names ids body env)
    (let ((freevars
            (set-diff (free-vars body) (lset-union eqv? proc-names ids))))
      (extend-env
        freevars
        (map
          (lambda (sym) (apply-env env sym))
          freevars)
        (empty-env)))))

; procedure

(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)
            (map (lambda (x) (a-ref 0 (vector x))) args)
            (extend-env-recursively
              proc-names idss bodies env)))))))

; interpreter

(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) (deref (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
                (map (lambda (x) (a-ref 0 (vector x))) (eval-rands rands env))))
          (eval-expression body (extend-env ids args env))))
      (proc-exp (ids body)
        (closure
          0
          (list '_)
          (list ids)
          (list body)
          (save-env '() ids 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!
            (apply-env env id)
            (eval-expression rhs-exp env))
          1))
      )))

(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-letrec-3.46
  '((white-sp
      (whitespace) skip)
    (comment
      ("%" (arbno (not #\newline))) skip)
    (identifier
      (letter (arbno (or letter digit "?"))) symbol)
    (number
      (digit (arbno digit)) number)))

(define grammar-letrec-3.46
  '((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-3.46
    grammar-letrec-3.46))

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

(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-letrec-3.46
      grammar-letrec-3.46)))