基于消息传递的 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 语言 的面向对象机制。
这个“系统”的完整代码在此下载，升级版本就算了吧 :)