EOPL 第3章の Exercise 3.23 と 3.24 [Lisp]
Exercise 3.23 は「レキシカル変数について名前は重要ではなく、レベルと位置で識別できる」という第1章で学んだことをいま作っている処理系に適用して lexical-address 関数のこの言語版を作る。このためにヴァリアント型に lexvar-exp を追加した。3.24 は apply-env を改造して変数が確かに lexical-address で予測された位置に現れるということの答えあわせができるようにする。
; Exercise 3.23 .. 3.24
(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))))
(define closure
(lambda (ids body env)
(lambda (args)
(if (= (length ids) (length args))
(eval-expression body (extend-env ids args env))
(eopl:error 'closure
"Wrong number of arguments: ~s required, but got ~s"
(length ids) (length args))))))
(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)
(proc-exp ids (la body (cons ids bs))))
(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-6
'((white-sp
(whitespace) skip)
(comment
("%" (arbno (not #\newline))) skip)
(identifier
(letter (arbno (or letter digit "?"))) symbol)
(number
(digit (arbno digit)) number)))
(define grammar-3-6
'((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-6
grammar-3-6))
(sllgen:make-define-datatypes scanner-spec-3-6 grammar-3-6)
(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-6
grammar-3-6)))
コメント 0