作者 Anonymous [scheme] 2012-03-20 13:40 (点击下载)

(define (class+- init-a init-b . args)
  (let ((a init-a)
        (b init-b))
    (define (dispatch m)
      (define (set-a! x)
        (set! a x))
      (define (set-b! y)
        (set! b y))
      (cond ((eq? m 'a) a)
            ((eq? m 'b) b)
            ((eq? m 'set-a!) set-a!)
            ((eq? m 'set-b!) set-b!)
            ((eq? m 'add) (+ (dispatch 'a) (dispatch 'b)))
            ((eq? m 'sub) (- (dispatch 'a) (dispatch 'b)))
            ((null? args) (error "Unknown message -- CLASS+-" m))
            (else #f)))
    dispatch))
 
(define (class+-*/ init-a init-b . args)
  (let ((parent-obj (class+- init-a init-b 'inheritance)))
    (define (dispatch m)
      (let ((super (delay (parent-obj m))))
        (cond ((eq? m 'mul) (* (dispatch 'a) (dispatch 'b)))
              ((eq? m 'div) (/ (dispatch 'a) (dispatch 'b)))
              ((eq? m 'a) (+ (force super) 1)) ;; Only for tests
              ((force super))
              ((null? args) (error "Unknown message -- CLASS+-*/"))
              (else #f))))
    dispatch))