Scheme - データによる抽象の構築(汎用演算のシステム(異なる方のデータの統合(強制型変換、型の階層構造、階層構造の不適切さ(異なる方の引数鵜と強制型変換、型の塔))))

計算機プログラムの構造と解釈
Gerald Jay Sussman, Julie Sussman
Harold Abelson (原著) 和田 英一 (翻訳)
異なる出版社で予約受付中

開発環境

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

計算機プログラムの構造と解釈(Gerald Jay Sussman(原著)、Julie Sussman(原著)、Harold Abelson(原著)、和田 英一(翻訳)、ピアソンエデュケーション、原書: Structure and Interpretation of Computer Programs (MIT Electrical Engineering and Computer Science)(SICP))の2(データによる抽象の構築)、2.5(汎用演算のシステム)、2.5.2(異なる方のデータの統合)、強制型変換、型の階層構造、階層構造の不適切さ、問題 2.84.を解いてみる。

その他参考書籍

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

問題 2.84.

コード(BBEdit, Emacs)

sample.scm

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

(define (raise x) (apply-generic 'raise x))

(define (apply-generic op .args)
  (define tower '(complex real rational integer))
  (define (higher type1 type2 tower)
    (if (null? tower)
        #f
        (let ((type (car tower)))
          (cond ((eq? type1 type) type1)
            ((eq? type2 type) type2)
            (else
             (higher type1 type2 (cdr tower)))))))
  (let ((type-tags (map type-tag args)))
    (let ((proc (get op type-tags)))
      (if proc
          (apply proc (map contents args))
          (if (= (length args) 2)
              (let ((type1 (car type-tags))
                    (type2 (cadr type-tags))
                    (a1 (car args))
                    (a2 (cadr args)))
                (if (eq? type1 type2)
                    (error "No method for these types"
                           (list op type-tags))
                    (let ((type (higher type1 type2 tower)))
                      (cond ((not type)
                             (error "No method for thse types"
                                    (list op type-tags)))
                            ((eq? type1 type)
                             (apply-generic op a1 (raise a2)))
                            (else
                             (apply-generic op (raise a1) a2))))))
              (error "No method for these types"
                     (list op type-tags)))))))

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

$ ./sample.scm
$