Scheme - 超言語的抽象(超循環評価器、式の表現(データ主導流で振り分けるeval))

計算機プログラムの構造と解釈
Gerald Jay Sussman, Julie Sussman
Harold Abelson (原著) 和田 英一 (翻訳)

開発環境

• OS X Lion - Apple(OS)
• Emacs、BBEdit - Bare Bones Software, Inc. (Text Editor)
• プログラミング言語: MIT/GNU Scheme

計算機プログラムの構造と解釈(Gerald Jay Sussman(原著)、Julie Sussman(原著)、Harold Abelson(原著)、和田 英一(翻訳)、ピアソンエデュケーション、原書: Structure and Interpretation of Computer Programs (MIT Electrical Engineering and Computer Science)(SICP))の4(超言語的抽象)、4.1(超循環評価器)、4.1.2(式の表現)、問題 4.3を解いてみる。

その他参考書籍

• Instructor's Manual to Accompany Structure & Interpretation of Computer Programs

問題 4.3

コード(BBEdit)

sample.scm

(define (eval exp env)
  (define (self-evaluating? exp)
    (cond ((number? exp) true)
          ((string? exp) true)
          (else false)))
  (define (variable exp)
    (symbol? exp))
  (define (application? exp)
    (pair? exp))
  (cond ((self-evaluating? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))
        (((get 'eval (operator exp)))
         (get 'eval (operator exp) (operands exp) env))
        ((application? exp)
         (apply (eval (operator exp) env)
                (list-of-values (operands exp) env)))
        (else
         (error "Unknown expression type -- EVAL" exp))))

(define (install-quoted-package)
  (define (inner-eval exp env)
    (text-of-quotation exp))
  (define (text-of-quotation exp)
    (cadr exp))
  
  (put 'eval 'quoted  inner-eval)
  'done)

(define (install-assignment-package)
  (define (eval-assignment exp env)
    (set-variable-value! (assignment-variable exp)
                         (eval (assignment-value exp) env)
                         env)
    'ok)
  (define (assignment-variable exp) (cadr exp))
  (define (assignment-value exp) (caddr exp))

  (put 'eval 'set! eval-assignment)
  'done)

(define (install-definition-package)
  (define (eval-definition exp env)
    (define-variable! (definition-variable exp)
                      (eval (definition-value exp) env)
                      env)
    'ok)
  (define (definition-variable exp)
    (if (symbol? (cadr exp))
        (cadr exp)
        (caadr exp)))
  (define (definition-value exp)
    (if (symbol? (cadr exp))
        (caddr exp)
        (make-lambda (cdadr exp)
                     (cddr exp))))
  (define (make-lambda parameters body)
    (cons 'lambda (cons parameters body)))

  (put 'eval 'define eval-definition)
  'done)

(define (install-if-packge)
  (define (eval-if exp env)
    (if (true? (eval (if-preicate exp) env))
        (eval (if-consequent exp) env)
        (eval (if-alternative exp) env)))

  (define (if-predicate exp) (cadr exp))
  (define (if-consequent exp) (caddr exp))
  (define (if-alternative exp)
    (if (not (null? (cdddr exp)))
        (cadddr exp)
        'false))
  
  (put 'eval 'if eval-if)
  'done)

(define (install-lambda-package)
  (define (make-procedure (lambda-parameters exp)
                          (lambda-body exp)
                          env))
  (define (lambda-parameters exp) (cadr exp))
  (define (lambda-body exp) (cddr exp))
  
  (put 'eval 'lambda make-procedure)
  'done)

(define (install-begin-package)
  (define (eval-sequence exps env)
    (cond ((last-exp? exps) (eval (first-exp exps) env))
          (else (eval (first-exp exps) env)
                (eval-sequence (rest-exps exps) env))))
  (define (last-exp? exps) (null? (cdr seq)))
  (define (first-exp exps) (car seq))
  (define (rest-exps exps) (cdr seq))
  
  (put 'eval 'begin eval-sequence)
  'done)

(define (install-cond-package)
  (define (cond->if exp)
    (expand-clauses (cond-clauses exp)))
  (define (expand-clauses clauses)
    (if (null? clauses)
        'false
        (let ((first (car clauses))
              (rest (cdr clauses)))
          (if (cond-else-clause? first)
              (if (null? rest)
                  (sequence->exp (cond-actions first))
                  (error "ELSE clause isn't last -- COND->IF"
                         clauses))
              (make-if (cond-predicate first)
                       (sequence->exp (cond-actions first))
                       (expand-clauses rest))))))
  (define (cond-else-clause? clause)
    (eq? (cond-predicate clause) 'else))
  (define (sequence-exp seq)
    (cond ((null? seq) seq)
          ((last-exp? seq) (first-exp seq))
          (else (make-bvegin seq))))
  (define (make-if predicate consequent alternative)
    (list 'if predicate consequent alternative))
  (define (cond-actions clause) (cdr clause))
  (define (cond-predicate clause) (car clause))
  (define (last-exp? seq) (null? (cdr seq)))
  (define (first-exp seq) (car seq))
  (define (make-begin seq) (cons 'begin seq))

  (put 'eval 'cond (lambda (exp env) 
                     (eval (cond->if exp) env)))
  'done)

なんか長くなった。