EOPL 第3章の Exercise 3.47 [Lisp]
練習問題 3.47 は setdynamic という式を追加して一時的な代入ができるようにする。
Perl の local とか Scala の DynamicVariable に近いかな。
; Exercise 3.47
(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) (closure x proc-names idss bodies old-env))
(iota (length proc-names))))
old-env)))
(define apply-env
(lambda (env sym)
(deref (apply-env-ref env sym))))
(define apply-env-ref
(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)
(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))))))
(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)))))))
(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 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!
(apply-env-ref env id)
(eval-expression rhs-exp env))
1))
; Excercise 3.47
(setdynamic-exp (id rhs-exp body)
(let ((save (apply-env env id)))
(setref!
(apply-env-ref env id)
(eval-expression rhs-exp env))
(let ((result (eval-expression body env)))
(setref! (apply-env-ref env id) save)
result)))
)))
(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-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)
; Excercise 3.47
(expression
("setdynamic" identifier "=" expression "during" expression)
setdynamic-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)
(eval-program
(scan&parse string))))
(define read-eval-print
(sllgen:make-rep-loop "-->" eval-program
(sllgen:make-stream-parser
scanner-spec-letrec-varassign
grammar-letrec-varassign)))
コメント 0