EOPL 第3章の Exercise 3.16 から 3.18: let の追加 [Lisp]
EOPL の続き。今回は let 式を追加。Exercise では eq? 関数とリストを変数に展開する unpack 式を追加した。
gosh> (read-eval-print) let x = 1 in x -->1 let x = list(1,2,3) in unpack x y z = x in +(1,+(2,3)) -->6 let x = list(1,2,3) in let y = x in eq?(x,y) -->#t
; Exercise 3.16 .. 3.18
(load "r5rs.scm")
(load "define-datatype.scm")
(load "sllgen.scm")
(load "./2.eopl.scm") ; for extend-env, empty-env
(define true-value (lambda () #t))
(define false-value (lambda () #f))
(define true-value?
(lambda (x)
(not (eq? #f x))))
(define-datatype program program?
(a-program
(exp expression?)))
(define-datatype expression expression?
(lit-exp
(datum number?))
(var-exp
(id symbol?))
(primapp-exp
(prim primitive?)
(rands (list-of expression?)))
(if-exp
(test-exp expression?)
(true-exp expression?)
(false-exp expression?))
(let-exp
(ids (list-of symbol?))
(rands (list-of expression?))
(body expression?))
(unpack-exp
(ids (list-of symbol?))
(exp expression?)
(body expression?))
)
(define-datatype primitive primitive?
(add-prim)
(subtract-prim)
(mult-prim)
(incr-prim)
(decr-prim)
(cons-prim)
(car-prim)
(cdr-prim)
(list-prim)
(eq?-prim)
)
(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)
(let ((result (eval-expression test-exp env)))
(if (boolean? result)
(if (true-value? result)
(eval-expression true-exp env)
(eval-expression false-exp env))
(eopl:error 'if-exp "test-exp not eval'd to bool"))))
(let-exp (ids rands body)
(let ((args (eval-rands rands env)))
(eval-expression body (extend-env ids args env))))
(unpack-exp (ids exp body)
(let ((lst (eval-expression exp env)))
(if (= (length ids) (length lst))
(eval-expression body (extend-env ids lst env))
(eopl:error 'unpack-exp "~s length list expexted" (length ids)))))
)))
(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))
(cons-prim () (cons (car args) (cadr args)))
(car-prim () (car (car args)))
(cdr-prim () (cdr (car args)))
(list-prim () args)
(eq?-prim () (eq? (car args) (cadr args)))
)))
(define init-env
(lambda ()
(extend-env
'(emptylist i v x)
'(() 1 5 10)
(empty-env))))
(define scanner-spec-3-4
'((white-sp
(whitespace) skip)
(comment
("%" (arbno (not #\newline))) skip)
(identifier
(letter (arbno (or letter digit "?"))) symbol)
(number
(digit (arbno digit)) number)))
(define grammar-3-4
'((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
("unpack" (arbno identifier) "=" expression "in" expression)
unpack-exp)
(primitive ("+") add-prim)
(primitive ("-") subtract-prim)
(primitive ("*") mult-prim)
(primitive ("add1") incr-prim)
(primitive ("sub1") decr-prim)
(primitive ("cons") cons-prim)
(primitive ("car") car-prim)
(primitive ("cdr") cdr-prim)
(primitive ("list") list-prim)
(primitive ("eq?") eq?-prim)
))
(define scan&parse
(sllgen:make-string-parser
scanner-spec-3-4
grammar-3-4))
(sllgen:make-define-datatypes scanner-spec-3-4 grammar-3-4)
(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-3-4
grammar-3-4)))
コメント 0