EOPL 第3章の Exercise 3.27 と 3.28

今まではクロージャ＝関数本体＋環境を作るときの環境として「クロージャが作られた時点での環境全体」を使ってきた。練習問題 3.27 と 3.28 ではこれを「クロージャが作られた時点の環境のうち関数本体で自由変数であるもの」（つまり必要なバインディングのみから成る環境）に変える。

この結果、例えば

let x = 1 in let y = 2 z = 3 in let f = proc (i) +(x,+(z,i)) in (f 3)

の f にくっつく環境は

(((y z) . #(2 3)) ((x) . #(1)) ((i v x) . #(1 5 10)))

ではなくて（最後の (i v x) は環境の初期値）

(((x z) . #(1 3)))

のようなフラットなものになる。

これに練習問題 3.24 のような lexical-address 関数を付けると

(lexvar-exp f 0 0) found at [0 : 0]
(lexvar-exp x 2 0) found at [1 : 0]
(lexvar-exp z 1 1) found at [1 : 1]
(lexvar-exp i 0 0) found at [0 : 0]

となり、x と z の位置が予測と一致しなくなるので合うように作り変えるのが練習問題 3.28 だ（本当はさらに名前でなく lexical address を使って評価を行うように作り変えるという注文もあるんだけどめんどいので省略）。

ところでこのような改変は一体どんな利点があるんだろうか。一見節約している風だけど、逆に環境を作り直す分だけメモリやコストがかかるような気もする。ルックアップが速くなるかといえば微妙な感じだ。環境がいままでやってきたような関数的な実装じゃなかったとしたらバインディングを限定することの利点はありそうだけど。

それと現実の言語実装ではどうするのが多いのか？思い出したのはたしか Python のクロージャの中で locals 関数を使ってローカル変数の一覧を出すと「ローカル変数＋環境のうちクロージャ内で使われている変数だけ」を出してくれるはずだけど Python ではひょっとしてこういう分析をしているのかな。

; Exercise 3.27, 3.28
(load "r5rs.scm")
(load "define-datatype.scm")
(load "sllgen.scm")

(define empty-env
  (lambda () '()))

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

(define apply-env
  (lambda (env exp depth)
    (if (null? env)
      (eopl:error 'apply-env "No binding for ~s" exp)
      (let ((syms (car (car env)))
            (vals (cdr (car env)))
            (env (cdr env))
            (sym
              (cases expression exp
                (lexvar-exp (sym d p) sym)
                (var-exp (sym) sym)
                (else (eopl:error 'apply-env "unexpected case ~s" exp)))))
        (let ((pos (rib-find-position sym syms)))
          (if (number? pos)
            (begin
              (print (format"~s found at [~s : ~s]" exp depth pos))
              (vector-ref vals pos))
            (apply-env env exp (+ 1 depth))))))))

(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 rib-find-position list-find-position)

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

(use srfi-1)

(define free-vars
  (letrec ((fv (lambda (vars exp)
                 (cases expression exp
                   (lit-exp (datum) '())
                   (var-exp (id)
                     (if (memv id vars) '() (list id)))
                   (lexvar-exp (id d p)
                     (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))))
                   ))))
    (lambda (exp)
      (fv '() exp))))

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

(define closure
  (lambda (ids body env)
    (let ((freevars (set-diff (free-vars body) ids)))
      (let ((saved-env
              (extend-env
                freevars
                (map
                  (lambda (v)
                    (apply-env env (var-exp v) 0))
                  freevars)
                (empty-env))))
        (lambda (args)
          (eval-expression body
            (extend-env ids args saved-env)))))))

(define lexical-address
  (lambda (pgm)
    (letrec
      ((la
         (lambda (exp bs)
           (cases expression exp
             (lit-exp (datum) exp)
             (var-exp (id) (get-address id bs 0))
             (lexvar-exp (v d p) exp)
             (primapp-exp (prim rands)
               (primapp-exp prim (map (lambda (x) (la x bs)) rands)))
             (if-exp (test-exp true-exp false-exp)
               (if-exp (la test-exp bs) (la true-exp bs) (la false-exp bs)))
             (let-exp (ids rands body)
               (let-exp ids
                        (map (lambda (x) (la x bs)) rands)
                        (la body (cons ids bs))))
             (proc-exp (ids body)
               (let ((freevars (set-diff (free-vars body) ids)))
                 (proc-exp ids (la body (list ids freevars)))))
             (app-exp (rator rands)
               (app-exp (la rator bs) (map (lambda (x) (la x bs)) rands)))
             )))
       (get-address
         (lambda (var bs d)
           (cond
             ((null? bs) (var-exp var))
             ((memv var (car bs))
              (lexvar-exp var d (get-pos var (car bs))))
             (else
               (get-address var (cdr bs) (+ d 1))))))
       (get-pos
         (lambda (s lst)
           (if (eqv? s (car lst))
             0
             (+ 1 (get-pos s (cdr lst))))))
       )
      (cases program pgm
        (a-program (exp)
          (a-program (la exp '())))))))

(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 exp 0))
      (lexvar-exp (v d p) (apply-env env exp 0))
      (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-9
  '((white-sp
      (whitespace) skip)
    (comment
      ("%" (arbno (not #\newline))) skip)
    (identifier
      (letter (arbno (or letter digit "?"))) symbol)
    (number
      (digit (arbno digit)) number)))

(define grammar-3-9
  '((program
      (expression)
      a-program)
    (expression
      (number)
      lit-exp)
    (expression
      (identifier)
      var-exp)
    (expression
      ("[" identifier ":" number number "]")
      lexvar-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-9
    grammar-3-9))

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

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

(define read-eval-print
  (sllgen:make-rep-loop "-->" (lambda (x) (eval-program (lexical-address x)))
    (sllgen:make-stream-parser
      scanner-spec-3-9
      grammar-3-9)))