练习 2.78

目前的 scheme-number 包,当使用 make-scheme-number 产生一个值时,生成的是一个带 'scheme-number 标识的数字:

1 ]=> (load "p129-install-scheme-number-package.scm")

;Loading "p129-install-scheme-number-package.scm"...
;  Loading "p119-tag.scm"... done
;  Loading "p123-put-and-get.scm"... done
;... done
;Value: make-scheme-number

1 ]=> (install-scheme-number-package)

;Value: done

1 ]=> (make-scheme-number 10)

;Value 11: (scheme-number . 10)

题目要求我们修改 attach-tagtype-tagcontents 函数,使得可以直接使用 Scheme 的内置数字类型。

为了做到这一点,需要修改以上函数,让它们分别加上一条处理 Scheme 数字的特殊规则,使得 Scheme 数字值可以在不带 tag 的情况下进行计算。

attach-tag

以下是修改过的 attach-tag ,当输入为数字时,它直接返回输入:

;;; 78-attach-tag.scm

(define (attach-tag type-tag contents)
    (if (number? contents)
        contents
        (cons type-tag contents)))

需要注意的一点是,当输入为数字时,参数 type-tag 实际上是用不到的,没有去掉它是为了保持和原来的 (install-scheme-number) 包的兼容。

测试:

1 ]=> (load "78-attach-tag.scm")

;Loading "78-attach-tag.scm"... done
;Value: attach-tag

1 ]=> (attach-tag 'scheme-number 10)

;Value: 10

1 ]=> (attach-tag 'rectangular (cons 3 4))

;Value 13: (rectangular 3 . 4)

type-tag

相应的, type-tag 也需要修改,当输入为数字时,它返回类型 'scheme-number

;;; 78-type-tag.scm

(define (type-tag datum)
    (cond ((number? datum)
            'scheme-number)
          ((pair? datum)
            (car datum))
          (else
            (error "Bad tagged datum -- TYPE-TAG" datum))))

测试:

1 ]=> (load "78-type-tag.scm")

;Loading "78-type-tag.scm"... done
;Value: type-tag

1 ]=> (type-tag 10)

;Value: scheme-number

1 ]=> (type-tag (cons 'rectangular (cons 3 4)))

;Value: rectangular

contents

contents 在遇到数字输入时,直接返回它:

;;; 78-contents.scm

(define (contents datum)
    (cond ((number? datum)
            datum)
          ((pair? datum)
            (cdr datum))
          (else
            (error "Bad tagged datum -- CONTENT" datum))))

测试:

1 ]=> (load "78-contents.scm")

;Loading "78-contents.scm"... done
;Value: contents

1 ]=> (contents 10)

;Value: 10

1 ]=> (contents (cons 'rectangular (cons 3 4)))

;Value 14: (3 . 4)

测试

使用覆盖的方式,在解释的最后载入前面重定义的三个函数,然后对 scheme 数值包进行测试:

1 ]=> (load "p129-install-scheme-number-package.scm")

;Loading "p129-install-scheme-number-package.scm"...
;  Loading "p119-tag.scm"... done
;  Loading "p123-put-and-get.scm"... done
;... done
;Value: make-scheme-number

1 ]=> (load "p129-generic-op.scm")                          ; 载入通用操作 add , sub , ...

;Loading "p129-generic-op.scm"...
;  Loading "p125-apply-generic.scm"...
;    Loading "p119-tag.scm"... done
;  ... done
;... done
;Value: div

1 ]=> (load "78-attach-tag.scm")                            ; 载入重新定义的 tag 处理函数

;Loading "78-attach-tag.scm"... done
;Value: attach-tag

1 ]=> (load "78-type-tag.scm")

;Loading "78-type-tag.scm"... done
;Value: type-tag

1 ]=> (load "78-contents.scm")

;Loading "78-contents.scm"... done
;Value: contents

1 ]=> (install-scheme-number-package)

;Value: done

1 ]=> (define ten (make-scheme-number 10))

;Value: ten

1 ]=> ten

;Value: 10

1 ]=> (contents ten)

;Value: 10

1 ]=> (type-tag ten)

;Value: scheme-number

1 ]=> (add ten ten)

;Value: 20

讨论

blog comments powered by Disqus