September 22, 2007

基于消息传递的 Scheme OOP

续上次的OOP 诡异教程,我用 Scheme 宏写了一个类似的系统,拿来晒晒。

;; 这里只有部分定义,快速排序和二分法查找的代码就不帖在这儿了
;; 这里是 slot 类型的定义,Scheme 中不能动态 eval,只能用点别的招数
(define (make-slot name act) (cons name act))
(define (slot-name s) (car s))
(define (slot-act s) (cdr s))
(define (slotstring a) (symbol->string b)))

;; 主要的转换宏,语法比较丰富,但至少要带有一个 that 块
;; 语法可以只给出 that 块:(class (that (slot-name1 slot-act1) ...))
;; 也可以指定继承,要求在 class 关键字后出现原型对象:
  ;;(class extended-obj (that (slot-name1 slot-act1) ...))
;; 在 that 块之后还可以加入 where 块,这样可以指定不对外可见的类属性
;; 需要注意的是,where 块中的定义不能引用 self 等特殊命名,that 才行
;; 另外外部只能引用 origin, has-slot?, slot-names 3个特殊命名
(define-syntax class
(syntax-rules (that where)
 ((_ that-block)
  (class (absobj) that-block))
 ((_ org that-block (where def ...))
  (letrec (def ...) (class (absobj) that-block)))
 ((_ org (that (slot val) ...))
  (lambda ()
   (letrec ((slot val) ...)
   (let* ((origin org)
       (slots (list-qsort slotvector (map slot-name slots)))
       (slot-acts (list->vector (map slot-act slots)))
       (has-slot? (lambda (v)
             (vector-bsearch symbol index -1)
           (vector-ref slot-acts index)
           (case verb
            ('origin origin)
            ('slot-names slot-names)
            ('has-slot? has-slot?)
            (else (origin verb))))))))
    self))))
 ((_ that-block where-block)
  (class (absobj) that-block where-block))))

;; 这里需要注意的是,因为嫌烦,absobj 被实现为了一个空壳子
(define (absobj)
(lambda (verb)
 (display "This object can't handle ")
 (display verb)
 (newline)))

测试一下:
> (define c1 (class (that (x 10))))
; no values returned
> (define c2 (class (c1) (that (z 16) (y 12))))
; no values returned
> (define o2 (c2))
; no values returned
> (o2 'x)
10
> (o2 'non-slot)
This object can't handle non-slot
#{Unspecific}
> (o2 'slot-names)
'#(y z)
> (o2 'origin)
#{Procedure 8647 (self##497 in c1)}

输出好像很古怪的样子~`我用的环境是 Scheme 48 虚拟机
这儿的例子只覆盖了一小部分,剩下的比如 where 就自己慢慢玩吧。
Scheme 的“卫生宏”不但强大,还能制止你设计不好的语法,有意思。
消息传递真的很有意思。留个小题目,增加一个特殊方法 clone,把继承机制调整为差异继承+纯基于对象,类似 IO 语言 的面向对象机制。
这个“系统”的完整代码在此下载,升级版本就算了吧 :)

No comments: