EOPL 第3章の Exercise 3.34 から 3.36

3.6 節では letrec を追加して再帰関数を定義できるようにする。この EOPL 言語には大域変数はないので関数内関数の再帰に相当する話になる。

興味深かったのは、私は再帰をする場合は循環構造が出来るので完全な関数型的には書けずに破壊的更新をどこかでしなければならなくなるんだろうと思っていたのだけど、クロージャの生成を apply 時まで遅延させるやり方ではコード上のどこにも非関数的な記述がでてこなくてよい。ただこれだと関数が必要になるたびにクロージャの生成が行われるので循環構造を作ったほうが効率がよい。

練習問題 3.34 は「名前なし環境」でこの再帰を出来るように拡張するという問題で、3.35 はクロージャの生成が「最大1回」（不要なときは生成されない）になるようにする。この2つをまとめてやった。

ここでは例えば

letrec fact(x) = if x then *(x,(fact sub1(x))) else 1 in (fact 5)

という プログラムから以下の構文木ができることになる。

(a-program
  (letrec-exp (fact)
              ((x))
              ((if-exp (lexvar-exp 0 0)
                       (primapp-exp (mult-prim)
                                    ((lexvar-exp 0 0)
                                     (app-exp (lexvar-exp 1 0)
                                              ((primapp-exp (decr-prim)
                                                            ((lexvar-exp 0 0)))))))
                       (lit-exp 1)))
              (app-exp (lexvar-exp 0 0) ((lit-exp 5)))))

「最大1回」はメモ化の要領で実現した。

[追記] よく見たらメモ化の条件分岐がすっぽり抜けてたのを修正。ついでに 3.36 の回答もマージした。毎回クロージャを作る実装と1回しか作らないのとでは eq? が関与するプログラムで違いが出る。

; Exercise 3.34,35
(load "r5rs.scm")
(load "define-datatype.scm")
(load "sllgen.scm")
(use srfi-1)

(define empty-nameless-env
  (lambda ()
    (lambda (depth position)
      (eopl:error 'apply-env "No binding"))))

(define extend-nameless-env
  (lambda (vals env)
    (let ((rib (list->vector vals)))
      (lambda (depth position)
        (if (> depth 0)
          (apply-nameless-env env (- depth 1) position)
          (vector-ref rib position))))))

(define extend-nameless-env-recursively
  (lambda (proc-names idss bodies old-env)
    (letrec
      ((rib (make-vector (length proc-names) #f))
       (rec-env
         (lambda (depth position)
           (if (> depth 0)
             (apply-env old-env (- depth 1) position)
             (let ((proc (vector-ref rib position)))
               (if proc
               ;(if #f  ; 上の行をこれと取り替えると 3.36 の結果が変わる
                 proc
                 (let ((proc
                         (closure
                           (list-ref idss position)
                           (list-ref bodies position)
                           rec-env)))
                   (vector-set! rib position proc)
                   proc)))))))
      rec-env)))

(define apply-nameless-env
  (lambda (env depth position)
    (env depth position)))

(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-nameless-env args env))
        (eopl:error 'closure
                    "Wrong number of arguments: ~s required, but got ~s"
                    (length ids) (length args))))))

; 構文木中の変数をすべて lexical address に変換して返す
(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 (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)
               (proc-exp ids (la body (cons ids bs))))
             (app-exp (rator rands)
               (app-exp (la rator bs) (map (lambda (x) (la x bs)) rands)))
             (letrec-exp (proc-names idss bodies letrec-body)
               (let ((new-bs (cons proc-names bs)))
                 (letrec-exp proc-names
                             idss
                             (map
                               (lambda (x) (la (cadr x) (cons (car x) new-bs)))
                               (zip idss bodies))
                             (la letrec-body new-bs))))
             )))
       (get-address
         (lambda (var bs d)
           (cond
             ((null? bs) (var-exp var))
             ((memv var (car bs))
              (lexvar-exp 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)
        (eopl:error 'eval-expression "~s is not lexical variable" id))
      (lexvar-exp (d p) (apply-nameless-env env d p))
      (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-nameless-env 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)))
     (letrec-exp (proc-names idss bodies letrec-body)
        (eval-expression letrec-body
          (extend-nameless-env-recursively
            proc-names idss bodies env)))
      )))

(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 () (eq? (car args) (cadr args)))
      )))

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

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

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

(define grammar-3.34
  '((program
      (expression)
      a-program)
    (expression
      (number)
      lit-exp)
    (expression
      (identifier)
      var-exp)
    (expression
      ("[" 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)
    (expression
      ("letrec"
       (arbno
         identifier "(" (separated-list identifier ",") ")" "=" expression)
       "in" expression)
      letrec-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-3.34
    grammar-3.34))

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

(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.34
      grammar-3.34)))

; Exercise 3.36
; letrec f(x) = x in eq?(f,f)

コメント 1

hey,do u have the question for other exercise of epol??
can you email me?
I very appreciation your help:)

[e-mail]13415
by vivian (2008-02-15 19:03)