2.78

练习 2.78 包 scheme-number 里的内部过程几乎什么也没做，只不过是去调用基本过程 +、- 等等。直接使用语言的基本过程当然是不可能的，因为我们的类型标志系统要求每个数据对象都附加一个类型。然而，事实上所有Lisp实现都有自己的类型系统，使用在系统实现的内部，基本谓词 symbol? 和 number? 等用于确定某个数据对象是否具有特定的类型。请修改2.4.2节中type-tag、contents和attach-tag的定义，使我们的通用算术系统可以利用Scheme的内部类型系统。这也就是说，修改后的系统应该像原来一样工作，除了其中常规的数直接采用Scheme的数形式，而不是表示为一个car部分是符号scheme-number的序对。

先看一下原本的效果，以 add 为例：

(define helper (js-eval "const table = {}; function get (op, type) {console.log('getting ', op, type);    return table[op][JSON.stringify(type)];} function put (op,type, proc) {    table[op] = table[op] || {};    table[op][JSON.stringify(type)] = proc; } const exports = {get, put, table}; exports;"))

(define JSON (js-eval "JSON"))

(define (get op type)
    (js-invoke helper 'get op type)
)

(define (put op type proc)
    (js-invoke helper 'put op type proc)
)

(define (error msg v)
    msg
)

(define (attach-tag type-tag contents)
    (cons type-tag contents)
)

(define (type-tag datum)
    (if (pair? datum)
        (car datum)
        (error (string-append "Bad tagged datum -- TYPE-TAG" datum))
    )
)

(define (contents datum)
    (if (pair? datum)
        (cdr datum)
        (error "Bad tagged datum -- CONTENTS" datum)
    )
)

(define (rectangular? z)
    (eq? (type-tag z) 'rectangular)
)

(define (polar? z)
    (eq? (type-tag z) 'polar)
)

(define (apply-generic op . args)
    (let ((type-tags (map type-tag args)))
        (let ((proc (get op '(scheme-number, scheme-number))))
            (if proc
                (apply proc (map contents args))
                (error
                    "No method for these types -- APPLY-GENERIC"
                    (list op type-tags)
                )
            )
        )
    )
)

(define (add x y) (apply-generic 'add x y))

(define (install-scheme-number-package)
    (define (tag x) (attach-tag 'scheme-number x))

    (put 'add '(scheme-number, scheme-number) (lambda (x y) (tag (+ x y))))
    (put 'make 'scheme-number (lambda (x) (tag x)))

    'done
)

(install-scheme-number-package)

(define (make-scheme-number n)
    ((get 'make 'scheme-number) n)
)

(define a (make-scheme-number 1))
(define b (make-scheme-number 2))

(add a b)

现在希望支持直接的数形式，也就是希望如下结果是 3。

(add 1 2)

然而却报错了，这是由于 type-tag 的定义导致的，它只能处理序对，而不能处理数。改写 type-tag 为：

(define (attach-tag type-tag contents)
    (cons type-tag contents)
)

(define (type-tag datum)
    (if (pair? datum)
        (car datum)
        'scheme-number
    )
)

(define (contents datum)
    (if (pair? datum)
        (cdr datum)
        datum
    )
)

再来计算：

(add 1 2)

同时，它也支持 scheme-number：

(add a b)