So-net無料ブログ作成
検索選択

EOPL 第3章の Exercise 3.10 から 3.15 [Lisp]

3.3 節ではインタプリタに条件式を追加した。

最初は真偽値を使わずにゼロ/非ゼロで代用するんだけど、練習問題の 3.14 では扱う値に Bool を追加してさらに if の条件節に Bool が来なかった場合はエラーとするように改造する。
その一方で 3.15 では <bool-exp> という新しい nonterminal を追加する。

練習問題 3.15 は何をやったことになるんだろうか。これだと if の条件節に <bool-exp> がこなかった場合は実行時でなくパース時のエラーになるというところがよい?出来上がったものを見るとなんかもやっとしたものを感じるけど。

; Exercise 3.11 .. 3.14
(load "r5rs.scm")
(load "define-datatype.scm")
(load "sllgen.scm")
(load "2-3-2.scm") ; for extend-env etc.

(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?))
  (cond-exp
    (test-exps (list-of expression?))
    (conseq-exps (list-of expression?)))
  )

(define-datatype primitive primitive?
  (add-prim)
  (subtract-prim)
  (mult-prim)
  (incr-prim)
  (decr-prim)
  (print-prim)
  (minus-prim)
  (cons-prim)
  (car-prim)
  (cdr-prim)
  (list-prim)
  (equal?-prim)
  (zero?-prim)
  (greater?-prim)
  (less?-prim)
  (null?-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"))))
      (cond-exp (test-exps conseq-exps)
        (letrec
          ((cnd
             (lambda (ts cs)
               (if (or (null? ts) (null? cs))
                 (false-value)
                 (let ((result (eval-expression (car ts) env)))
                   (if (boolean? result)
                     (if (true-value? result)
                       (eval-expression (car cs) env)
                       (cnd (cdr ts) (cdr cs)))
                     (eopl:error 'cond-exp "test-exp not eval'd to bool")))))))
          (cnd test-exps conseq-exps)))
      )))

(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))
      (print-prim () (begin (print (car args)) 1))
      (minus-prim ()  (- (car args)))
      (cons-prim () (cons (car args) (cadr args)))
      (car-prim () (car (car args)))
      (cdr-prim () (cdr (car args)))
      (list-prim () args)
      (equal?-prim () (if (= (car args) (cadr args))
                        (true-value)
                        (false-value)))
      (zero?-prim () (if (= (car args) 0) (true-value) (false-value)))
      (greater?-prim () (if (> (car args) (cadr args))
                          (true-value)
                          (false-value)))
      (less?-prim () (if (< (car args) (cadr args))
                       (true-value)
                       (false-value)))
      (null?-prim () (if (null? (car args)) (true-value) (false-value)))
      )))

(define init-env
  (lambda ()
    (extend-env
      '(emptylist i v x)
      '(()        1 5 10)
      (empty-env))))

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

(define grammar-3-2
  '((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
      ("cond" (arbno expression "==>" expression) "end")
      cond-exp)
    (primitive ("+") add-prim)
    (primitive ("-") subtract-prim)
    (primitive ("*") mult-prim)
    (primitive ("add1") incr-prim)
    (primitive ("sub1") decr-prim)
    (primitive ("print") print-prim)
    (primitive ("minus") minus-prim)
    (primitive ("cons") cons-prim)
    (primitive ("car") car-prim)
    (primitive ("cdr") cdr-prim)
    (primitive ("list") list-prim)
    (primitive ("equal?") equal?-prim)
    (primitive ("zero?") zero?-prim)
    (primitive ("greater?") greater?-prim)
    (primitive ("less?") less?-prim)
    (primitive ("null?") null?-prim)
    ))

(define scan&parse
  (sllgen:make-string-parser
    scanner-spec-3-2
    grammar-3-2))

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

(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-2
      grammar-3-2)))
; Exercise 3.15
(load "r5rs.scm")
(load "define-datatype.scm")
(load "sllgen.scm")
(load "2-3-2.scm") ; for extend-env etc.

(define true-value (lambda () 1))
(define false-value (lambda () 0))
(define true-value?
  (lambda (x)
    (not (zero? 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 bool-exp?)
    (true-exp expression?)
    (false-exp expression?))
  (cond-exp
    (test-exps (list-of bool-exp?))
    (conseq-exps (list-of expression?)))
  )

(define-datatype bool-exp bool-exp?
  (boolapp-exp
    (prim bool-prim?)
    (rands (list-of expression?)))
  (boollit-exp
    (datum number?))
  (boolvar-exp
    (id symbol?))
  )

(define-datatype primitive primitive?
  (add-prim)
  (subtract-prim)
  (mult-prim)
  (incr-prim)
  (decr-prim)
  (print-prim)
  (minus-prim)
  (cons-prim)
  (car-prim)
  (cdr-prim)
  (list-prim)
  )

(define-datatype bool-prim bool-prim?
  (equal?-prim)
  (zero?-prim)
  (greater?-prim)
  (less?-prim)
  (null?-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)
        (if (true-value? (eval-bool-exp test-exp env))
          (eval-expression true-exp env)
          (eval-expression false-exp env)))
      (cond-exp (test-exps conseq-exps)
        (letrec
          ((cnd
             (lambda (ts cs)
               (cond
                 ((or (null? ts) (null? cs)) (false-value))
                 ((true-value? (eval-bool-exp (car ts) env))
                  (eval-expression (car cs) env))
                 (else
                   (cnd (cdr ts) (cdr cs)))))))
          (cnd test-exps conseq-exps)))
      )))

(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))
      (print-prim () (begin (print (car args)) 1))
      (minus-prim ()  (- (car args)))
      (cons-prim () (cons (car args) (cadr args)))
      (car-prim () (car (car args)))
      (cdr-prim () (cdr (car args)))
      (list-prim () args)
      )))

(define eval-bool-exp
  (lambda (exp env)
    (cases bool-exp exp
      (boolapp-exp (prim rands)
        (let ((args (eval-rands rands env)))
          (apply-bool-prim prim args)))
      (boollit-exp (datum) datum)
      (boolvar-exp (id) (apply-env env id))
      )))

(define apply-bool-prim
  (lambda (prim args)
    (cases bool-prim prim
      (equal?-prim () (if (= (car args) (cadr args))
                        (true-value)
                        (false-value)))
      (zero?-prim () (if (= (car args) 0) (true-value) (false-value)))
      (greater?-prim () (if (> (car args) (cadr args))
                          (true-value)
                          (false-value)))
      (less?-prim () (if (< (car args) (cadr args))
                       (true-value)
                       (false-value)))
      (null?-prim () (if (null? (car args)) (true-value) (false-value)))
      )))

(define init-env
  (lambda ()
    (extend-env
      '(emptylist i v x)
      '(()        1 5 10)
      (empty-env))))

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

(define grammar-3-3
  '((program
      (expression)
      a-program)
    (expression
      (number)
      lit-exp)
    (expression
      (identifier)
      var-exp)
    (expression
      (primitive "(" (separated-list expression ",") ")" )
      primapp-exp)
    (expression
      ("if" bool-exp "then" expression "else" expression)
      if-exp)
    (expression
      ("cond" (arbno bool-exp "==>" expression) "end")
      cond-exp)
    (bool-exp
      (bool-prim "(" (separated-list expression ",") ")" )
      boolapp-exp)
    (bool-exp
      (number)
      boollit-exp)
    (bool-exp
      (identifier)
      boolvar-exp)
    (primitive ("+") add-prim)
    (primitive ("-") subtract-prim)
    (primitive ("*") mult-prim)
    (primitive ("add1") incr-prim)
    (primitive ("sub1") decr-prim)
    (primitive ("print") print-prim)
    (primitive ("minus") minus-prim)
    (primitive ("cons") cons-prim)
    (primitive ("car") car-prim)
    (primitive ("cdr") cdr-prim)
    (primitive ("list") list-prim)
    (bool-prim ("equal?") equal?-prim)
    (bool-prim ("zero?") zero?-prim)
    (bool-prim ("greater?") greater?-prim)
    (bool-prim ("less?") less?-prim)
    (bool-prim ("null?") null?-prim)
    ))

(define scan&parse
  (sllgen:make-string-parser
    scanner-spec-3-3
    grammar-3-3))

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

(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-3
      grammar-3-3)))

しかしここまでで前回から2ページしか進んでいないな。まあ気長にやるしかないか。


nice!(0)  コメント(0)  トラックバック(0) 
共通テーマ:パソコン・インターネット

nice! 0

コメント 0

コメントを書く

お名前:
URL:
コメント:
画像認証:
下の画像に表示されている文字を入力してください。

トラックバック 0