Scheme - 超言語的抽象(超循環評価器(式の表現(導出された式(反復構造(while loop)の実装))))

計算機プログラムの構造と解釈[第2版]
(翔泳社)
ハロルド エイブルソン (著) ジュリー サスマン (著)
ジェラルド・ジェイ サスマン (著)
Harold Abelson (原著) Julie Sussman (原著)
Gerald Jay Sussman (原著) 和田 英一 (翻訳)

開発環境

• OS X Mavericks - Apple(OS)
• Emacs (CUI)、BBEdit - Bare Bones Software, Inc. (GUI) (Text Editor)
• Scheme (プログラミング言語)
• Gauche (処理系)

計算機プログラムの構造と解釈[第2版](ハロルド エイブルソン (著)、ジュリー サスマン (著)、ジェラルド・ジェイ サスマン (著)、Harold Abelson (原著)、Julie Sussman (原著)、Gerald Jay Sussman (原著)、和田 英一 (翻訳)、翔泳社、原書: Structure and Interpretation of Computer Programs (MIT Electrical Engineering and Computer Science)(SICP))の4(超言語的抽象)、4.1(超循環評価器)、4.1.2(式の表現)、導出された式、問題 4.9.を解いてみる。

その他参考書籍

• Instructor's Manual to Accompany Structure & Interpretation of Computer Programs
• プログラミングGauche (Kahuaプロジェクト (著), 川合 史朗 (監修), オライリージャパン)

問題 4.9.

コード(BBEdit, Emacs)

sample9.scm

#!/usr/bin/env gosh
;; -*- coding: utf-8 -*-

(define operations '())
(define (put op proc)
  (cons (list op proc) operations))
(define (get op)
  (define (inner operations)
    (if (null? operations)
        #f
        (let ((pair (car operations)))
          (if (eq? op (car pair))
              (cadr pair)
              (inner (cdr operations))))))
  (inner operations))
  
(define (eval exp env)
  (define (self-evaluating? exp)
    (cond ((number? exp) #t)
          ((string? exp) #t)
          (else #f)))
  (define (variable? exp) (symbol? exp))
  (define (application? exp) (pair? exp))
  (define (operator exp) (car exp))
  (define (operands exp) (cdr exp))
  (define (no-operands? ops) (null? ops))
  (define (first-operand ops) (car ops))
  (define (rest-operands ops) (cdr ops))
  
  (cond ((self-evaluating? exp) exp)
        ((variable? exp) (lookup-variable-value exp env))
        ((get (car exp))
         ((get (car exp)) exp env))
        ((application? exp)
         (apply (eval (operator exp) env)
                (list-of-values (operands exp) env)))
        (else
         (error "Unknown expression type -- EVAL" exp))))

(define (apply procedure arguments)
  (cond ((primitive-procedure? procedure)
         (apply-primitive-procedure procedure arguments))
        ((compound-procedure? procedure)
         (eval-sequence
          (procedure-body procedure)
          (extend-environment
           (procedure-parameters procedure)
           arguments
           (procedure-environment procedure))))
        (else
         (error
          "Unknown procedure type -- APPLY" procedure))))

(define (install-quoted-package)
  (define (text-of-quotation exp env) (cadr exp))
  
  (put 'quote text-of-quotation))

(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 'set! eval-assignment))

(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 (get 'make-lambda))

  (put 'define eval-definition))

(define (install-if-package)
  (define (eval-if exp env)
    (if (true? (eval (if-predicate exp) env))
        (eval (if-consequent exp) env)
        (eval (if-alternative exp) env)))
  (define (true? a) (eq? a #t))
  (define (if-predicate exp) (cadr exp))
  (define (if-consequent exp) (caddr exp))
  (define (if-alternative exp)
    (if (not (null? (cdddr exp)))
        (cadddr exp)
        #f))
  (define (make-if predicate consequent alternative)
    (list 'if predicate consequent alternative))

  (put 'make-if make-if)
  (put 'if eval-if))

(define (install-lambda-package)
  (define (lambda-parameters exp) (cadr exp))
  (define (lambda-body exp) (cddr exp))
  (define (make-lambda parameters body)
    (cons 'lambda (cons parameters body)))

  (put 'make-lambda make-lambda)
  (put 'lambda (lambda (exp env)
                 (make-procedure (lambda-parameters exp)
                                 (lambda-body exp)
                                 env))))

(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 (begin-actions exp) (cdr exp))
  (define (last-exp? seq) (null? (cdr seq)))
  (define (first-exp seq) (car seq))
  (define (rest-seq) (cdr seq))
  (define (sequence->exp seq)
    (cond ((null? seq) seq)
          ((last-exp? seq) (first-exp seq))
          (else (make-begin seq))))
  (define (make-begin seq) (cons 'begin seq))

  (put 'sequence->exp sequence->exp)
  (put 'make-begin make-begin)
  (put 'begin (lambda (exp env)
                (eval-sequence (begin-actions exp) env))))

(define (instll-cond-package)
  (define (cond-clauses exp) (cdr exp))
  (define (cond-else-clause? clause)
    (eq? (cond-predicate clause) 'else))
  (define (cond-predicate clause) (car clause))
  (define (cond-actions clause) (cdr clause))
  (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)
                       ;; 問題 4.5 拡張構文を使えるようにする
                       (if (eq? (cadr first) '=>)
                           (list (caddr first) (cond-predicate first))
                           (sequence->exp (cond-actions first)))
                       (expand-clauses rest))))))
  (define sequence->exp (get 'sequence->exp))
  (define make-if (get 'make-if))
  (put 'cond (lambda (exp env)
               (eval (cond->if exp) env))))

;; 問題 4.4
(define (install-and-package)
  (define (eval-and exp env)
    (if (null? (cdr exp))
        #t
        (eval-sequence (cdr seq) env)))
  (define (eval-sequence seq env)
    (cond ((null? (cdr seq))
           (if (eval (car seq) env)
               (car seq)
               #f))
          ((eval (car seq) env)
           (eval-sequence (cdr seq) env))
          (else #f)))

  (put 'and eval-and))

(define (install-or-package)
  (define (eval-or exp env)
    (if (null? (cdr exp))
        #f
        (eval-sequence (cdr seq) env)))
  (define (eval-sequence seq env)
    (cond ((null? seq) #f)
          ((eval (car seq) env) (car seq))
          (else
           (eval-sequence (cdr seq) env))))

  (put 'or 'eval-or))

;; 問題 4.6
(define (install-let-package)
  (define (let-clauses exp) (cdr exp))
  (define (let-vars-exps clauses) (car clauses))
  (define (let-vars seq)
    (if (null? (cdr seq))
        (list (caar seq))
        (cons (caar seq)
              (let-vars (cdr seq)))))
  (define (let-exps seq)
    (if (null? (cdr seq))
        (list (cadar seq))
        (cons (cadar seq)
              (let-exps (cdr seq)))))
  (define (let-body clauses) (cdr clauses))
  ;; 問題 4.8
  (define (let->combination exp)
    (let ((clauses (let-clauses exp)))
      (if (pair? (car clauses))
          (let ((seq (let-vars-exps clauses)))
            (let ((vars (let-vars seq))
                  (exps (let-exps seq))
                  (body (let-body seq)))
              (cons (make-lambda vars body) exps)))
          (let ((var (car clauses))
                (bindings (cadr clauses))
                (body (cddr clauses)))
            (let ((vars (let-vars bindings))
                  (exps (let-exps bindings)))
              (sequence->exp
               (list 'define var (make-lambda vars body))
               (cons var exps)))))))
  (define sequence->exp (get 'sequence->exp))
  (define make-lambda (get 'make-lambda))
  (define (make-vars-exps vars exps)
    (if (null? (cdr vars))
        (list (list (car vars) (car exps)))
        (cons (list (car vars) (car exps))
              (make-vars-exps (cdr vars) (cdr exps)))))
  ;; 問題 4.7のlet*で使うために追加
  (define (make-let vars exps body)
    (list 'let
          (make-vars-exps vars exps)
          body))
  (put 'make-let make-let)
  (put 'let (lambda (exp env)
              (let->combination exp))))

;; 問題 4.7
(define (install-let*-package)
  (define (let*-clauses exp) (cdr exp))
  (define (let*-vars-exps clauses) (car clauses))
  (define (let*-vars seq)
    (if (null? (cdr seq))
        (list (caar seq))
        (cons (caar seq)
              (let*vars (cdr seq)))))
  (define (let*-exps seq)
    (if (null? (cdr seq))
        (list (cadar seq))
        (cons (cadar seq)
              (let*-exps (cdr seq)))))
  (define (let*-body clauses) (cdr clauses))
  (define (let*->nested-lets exp)
    (let ((clauses (let*-clauses exp)))
      (let ((vars-exps (let*-vars-exps clauses))
            (body (let*-body clauses)))
        (let ((vars (let*-vars vars-exps))
              (exps (let*-exps vars-exps)))
          (expand vars exps body)))))
  (define (expand vars exps body)
    (if (null? (cdr vars))
        (make-let vars exps body)
        (make-let (list (car vars))
                  (list (car exps))
                  (expand (cdr vars)
                          (cdr exps)
                          body))))
  (define make-let (get 'make-let))

  (put 'let* (lambda (exp env)
               (let*-nested-lets exp))))

;; 問題 4.9 反復構造
(define (install-while-package)
  ;; make-ifとmake-beginから導出
  (define (eval-while exp env)
    (make-if (while-predicate exp)
             (make-begin (append (while-body exp)
                                 (list (eval-while exp env))))
             '()))
  (define (while-predicate exp) (cadr exp))
  (define (while-body exp) (caddr exp))
  (define make-if (get 'make-if))
  (define make-begin (get 'make-begin))

  (put 'while eval-while))

;; 使い方
;; (define i 0)
;; (while (< i 10)
;;        (list (print i)
;;              (set! i (+ i 1))))
;; 
;; output
;; 0
;; 1
;; 2
;; 3
;; 4
;; 5
;; 6
;; 7
;; 8
;; 9

(install-quoted-package)
(install-assignment-package)
(install-definition-package)
(install-if-package)
(install-lambda-package)
(install-begin-package)
(instll-cond-package)
(install-and-package)
(install-or-package)
(install-let-package)
(install-let*-package)
(install-while-package)

入出力結果(Terminal(gosh), REPL(Read, Eval, Print, Loop))

$ ./sample9.scm
$