一种Scheme语言中基于消息传递的面向对象机制 上 -- 语言机制

以下代码是单纯为了试一试在Scheme里面使用使用面向对象机制而写。
大致可行不过仍需完善，利用更多常见的使用情况还需要单独地特别考虑一下。

代码贴在这里格式乱掉了。。。

其实OO有很多中实现方式，这里主要是使用闭包了。
闭包有天然的作用域可以作为访问控制
----
http://pastebin.com/ifbtVEPS

;#lang r5rs
;(define error display)
;;;一种Scheme语言中基于消息传递的面向对象机制 上 -- 语言机制 - Closure
;;;面向对象的机制的实现方式很都多种，常见的比如基于向量和隐藏this指针的。
;;;这里是基于程序语言中的闭包特性来实现的，尝试了面向对象机制中的一些常见情况。
;;;参考1 OCaml http://caml.inria.fr/pub/docs/u3-ocaml/ocaml-objects.html
;;;参考2 SICP http://mitpress.mit.edu/sicp/full-text/book/book-Z-H-17.html
;;;参考3 R5RS http://www.schemers.org/Documents/Standards/R5RS/HTML/
;;;查找对象方法的时间复杂度依赖所用实现的case语句的实现方式，若有优化则为O(1)。


;;;========================= 定义部分 ============================

;;;function send
;;;向对象发送消息
;;;type = closure * symbol * object list -> object
;;;example. (send pair 'set-car! 1) == (set-car! pair 1)
(define (send object method . arguments)
(cond ((object method)
=>(lambda (x) (apply x arguments)))
(else (error "method missing"))))
;;;function interface
;;;检验对象是否实现方法，注意方法名一致不能保证方法的语义正确
;;;type = symbol list -> (closure -> boolean)
;;;example. sequence? == (interface 'car 'cdr)
(define (interface . methods)
(lambda (object)
(let loop ((methods methods))
(cond ((null? methods) #t)
((not (object (car methods))) #f)
(else (loop (cdr methods)))))))
;;;functon coerce
;;;将对象绑定的若干方法表示为列表，用于调用泛型函数使用
;;;type = symbol list -> procedure list
;;;example. (coerce 'car 'cdr)
(define (coerce . methods)
(map (lambda (method)
(lambda (object . arguments) (apply send object method arguments)))
methods))
;;;function method
;;;从对象链中查找方法
;;;type = symbol * closure list -> (procedure | false)
;;;example. ((method 'car pair)) == (send pair 'car)
(define (method symbol . objects)
(let loop ((protos objects))
(cond ((null? protos) #f)
(((car protos) symbol) => (lambda (x) x))
(else (loop (cdr protos))))))
;;;macro object
;;;创建对象
;;;syntax = (object (prototypes ...) ((method (arguments ...) body ...) ...))
;;;example. (send (object () ((one () 1)))) 'one) == 1
(define-syntax object
(syntax-rules ()
((_ (prototypes ...) ((method-name (arguments ...) body ...) ...))
(lambda (m)
(case m
((method-name) (lambda (arguments ...) body ...)) ...
(else (apply method m (list prototypes ...))))))))
;;;macro thunk
;;;用于延迟绑定
;;;syntax = (thunk object)
;;;example. (thunk 0)
(define-syntax thunk
(syntax-rules () ((_ x) (lambda () x))))
;;;;macro object2
;;;上述“macro object”的 rich 版本
;;;syntax = (object2 self (prototype-news ...) ((slot value) ...) ((method (arguments ...) body ...) ...) init ...)
;;;example. <404>
(define-syntax object2;define
(syntax-rules ()
((_ self (prototype-news ...) ((slot value) ...) ((method (arguments ...) body ...) ...) init ...)
(letrec ((slot value) ...
(self
(lambda (m)
(case m
((method) (lambda (arguments ...) body ...)) ...
(else (let loop ((protos (list (prototype-news (lambda () self)) ...)))
(cond ((null? protos) #f)
(((car protos) m) => (lambda (x) x))
(else (loop (cdr protos))))))))))
init ... self))))
;;;object top-object2
;;;用于继承树的根节点
(define (top-object2 this)
(object2 self () () ((init () (this)))))
;;;function new
;;;用来构造一个对象
(define (new class . arguments)
(define self (apply send (class (thunk self)) 'init arguments))
self)
;;;========================= 示例部分 ============================

;;;* 示例一 Pair::mcons
;;;该示例用来演示如何创建一个对象
;;;定义A
(define (mcons0 x y)
(lambda (m)
(case m
((car) (lambda () x))
((cdr) (lambda () y))
((set-car) (lambda (z) (set! x z)))
((set-cdr) (lambda (z) (set! x z)))
((->pair) (lambda ()(cons x y)))
(else #f))))
;;;定义B
(define (mcons x y)
(object ()
((car () x)
(cdr () y)
(set-car (z) (set! x z))
(set-cdr (z) (set! y z))
(->pair () (cons x y)))))
;;;泛型
(define (mcar mpair)
((mpair 'car)))
(define (mcdr mpair)
((mpair 'cdr)))
(define (set-mcar mpair obj)
((mpair 'set-car) obj))
(define (set-mcdr mpair obj)
((mpair 'set-cdr) obj))
(define (mpair->pair mpair)
((mpair '->pair)))
;;;使用
(let example-1 ()
(define x (mcons 1 2))
(display (mcdr x))
(newline))

;;;* 示例二 sequence
;;;该示例用来演示接口和泛型的使用
(define sequence? (interface 'car 'cdr))
(define (mlist . objects)
(if (null? objects) '()
(mcons (car objects) (apply mlist (cdr objects)))))
(define (for-each0 p lst)
(cond ((null? lst) '())
(else (p (car lst)) (for-each p (cdr lst)))))
(define (mfor-each p lst)
(cond ((null? lst) '())
(else (p (mcar lst)) (mfor-each p (mcdr lst)))))
(define (generic-for-each prod lst car cdr)
(cond ((null? lst) '())
(else (prod (mcar lst)) (generic-for-each prod (mcdr lst) car cdr))))
(define (mrange start end step)
(letrec ((self (object()
((car () start)
(cdr () (let ((x (+ (send self 'car) step)))
(if (cond ((> step 0) (<= start x end))
((< step 0) (>= start x end))
(else (error "mrange")))
(mrange x end step) '())))))))
self))
(let example-2 ()
(define x (mlist 1 2 3 4 5))
(mfor-each display x)
(display (sequence? x))
;(mfor-each display (mrange 0 10 2))
;(generic-for-each display (mrange 0 10 2) mcar mcdr)
(apply generic-for-each display (mrange 0 -10 -3) (coerce 'car 'cdr))
(newline))

;;;* 示例三 slots
;;;该示例用来演示构造器和私有成员
(define (box x)
(letrec ((value '())
(self (object()
((ref () value)
(set! (x) (set! value x))
(add! (x) (send self 'set! (+ x (send self 'ref))))))))
(set! value x)
self))
(let example-3 ()
(define x (box 1))
(display (send x 'ref))
(send x 'set! 2)
(display (send x 'ref))
(send x 'add! 2)
(display (send x 'ref))
(newline))

;;;* 示例四 inheritance
;;;该示例用来演示扩充一个类
(define (mlist2 . objects)
(define super (apply mlist objects))
(define self
(object (super)
((for-each (prod) (apply generic-for-each prod self (coerce 'car 'cdr))))))
self)
(let example-4 ()
(define x (mlist2 1 2 3 4 5))
(mfor-each display x)
(send x 'for-each display)
(newline))

;;;* 实例五 virtual/override
;;;该示例用来演示模板方法模式
(let example-5 ()
(define (hello name)
(letrec((self
(object ()
((name () (name))
(say () (for-each display (list "hello " (send self 'name) "!\n")))))))
self))
(send (hello (lambda () "world0")) 'say)
(define (hello-world)
(define super (hello (lambda () (send self 'name))))
(define self (object (super) ((name () "world1"))))
self)
(send (hello-world) 'say)
(define (hello2 this)
(object ()
((name () "")
(say () (for-each display (list "hello " (send (this) 'name) "!\n"))))))
(define (hello-world2)
(define self
(object
((hello2 (thunk self)))
((name () "world2"))))
self)
(send (hello-world2) 'say)
(define (hello-world3)
(define self
(object2 self (top-object2 hello2) ()
((name () "world3"))))
self)
(send (hello-world3) 'say)
(define (hello-world4 this)
(define self
(object2 self (top-object2 hello2) ()
((name () "world4"))))
self)
(send (new hello-world4) 'say)
(newline))

;;;待续 一种Scheme语言中基于消息传递的面向对象机制 下 -- 使用模式


-----小改动，直接放在下面了----
不过话说这样更像Java而不是OCaml了。。。

(define-syntax object3;define
(syntax-rules (using method)
((_ ((method-name (arguments ...) body ...) ...))
(lambda (m)
(case m
((method-name) (lambda (arguments ...) body ...)) ...
(else #f))))
((_ super class using (traits ...) self ((slot value) ...) method ((method-name (arguments ...) body ...) ...))
(letrec ((super (class (lambda () self)))
(slot value) ...
(self
(lambda (m)
(case m
((method-name ) (lambda (arguments ...) body ...)) ...
(else (let loop ((protos (list super (traits (lambda () self)) ...)))
(cond ((null? protos) #f)
(((car protos) m) => (lambda (x) x))
(else (loop (cdr protos))))))))))
self))
((_ super class self ((slot value) ...) method ((method-name (arguments ...) body ...) ...))
(_ super class using () self ((slot value) ...) method ((method-name (arguments ...) body ...) ...)))
((_ super class self method ((method-name (arguments ...) body ...) ...))
(_ super class using () self () method ((method-name (arguments ...) body ...) ...)))
))
(define (root this)
(object3 ((init () (this)))))
(define (new class . arguments)
(define self (class (thunk self)))
(apply send (class (thunk self)) 'init arguments)
self)
(define (hello-world6 this)
(object3 super root using (hello2) self () method
((init () (send super 'init))
(name () "world6")
(say1 () (send (this) 'say)))))
(send (new hello-world6) 'say1)

-----
这样下去，干脆定义一个define-class算了。。。
用super表示父类（只有一个父类）this表示子类的对象，self表示当前类的对象。
这样好像把问题弄得复杂一下子就全部放在表面的问题。
由于用的是R5RS的“高级”“卫生”宏/语法，所以功能上有较多约束，不过有这些约束写起来还是更清爽了一些。
----
补充，感觉还是让object语法“小”一些比较好，多父类的判断可以移到语法宏的外面。
此外，多个原型也可以在子类中选择的调用，即不止一个spuer代表某个原型吧。
恩，其实OCaml里的对象是作为一种结构来实现的，要类型的话让闭包返回类型的联合也成吧。
嘛，这里也没多说清楚是怎么回事情，不过就是再补充一下了。