s7 scheme には hash-table があり、
(let ((ht (hash-table 'a 1 'b 2)))
(set! (ht 'b) 3)
(set! (ht 'c) 4)
(format *stdout* "a=~A, b=~A, c=~A\n" (ht 'a) (ht 'b) (ht 'c)))
-> a=1, b=3, c=4
みたいな感じで関数のように呼び出せる。
で、これとクロージャの仕組みを利用して以下のようにデータ隠蔽みたいなことができる。
(define (point-3d x y z)
(let* ((print-this (lambda ()
(format *stdout* "x=~A, y=~A, z=~A\n" x y z)))
(get-x (lambda () x))
(get-y (lambda () y))
(get-z (lambda () z))
(plus (lambda (p)
(print-this)
(point-3d (+ x ((p 'get-x)))
(+ y ((p 'get-y)))
(+ z ((p 'get-z)))))))
(hash-table 'get-x get-x 'get-y get-y 'get-z get-z 'plus plus)))
(let ((p1 (point-3d 1 2 3))
(p2 (point-3d 3 4 5)))
(let ((p3 ((p1 'plus) p2)))
(format *stdout* "x:~A, y:~A, z:~A\n"
((p3 'get-x))
((p3 'get-y))
((p3 'get-z)))))
-> x=1, y=2, z=3
-> x:4, y:6, z:8
ハッシュテーブルからクロージャを参照して呼び出している。
で、上記を踏まえて以下に実装したのが define-class というマクロ。
(define-macro (define-class constructor base privates publics)
(let ((class-name (symbol->string (car constructor))))
`(define ,constructor
(let ((this ,(if base base '(hash-table))))
(letrec* ,(append privates publics)
,@(map (lambda (public)
(let* ((name (car public))
(name2 (string->symbol
(string-append class-name ":"
(symbol->string name)))))
`(begin
(set! (this (quote ,name)) ,name)
(set! (this (quote ,name2)) ,name))))
publics)
this)))))
使い方は、
(define-class (クラス名 メンバ名 ...)
基底クラスの呼び出しまたは#f
((隠蔽メンバ名 値)
...)
((公開メンバ名 値)
...))
使用例は、
(define-class (point-2d x y)
#f
((print-this (lambda ()
(format *stdout* "x=~A, y=~A\n" x y))))
((get-x (lambda () x))
(get-y (lambda () y))
(plus (lambda (p)
(print-this)
(point-2d (+ x ((p 'get-x)))
(+ y ((p 'get-y))))))))
(define-class (point-3d _x _y z)
(point-2d _x _y)
((print-this (lambda ()
(format *stdout* "x=~A, y=~A, z=~A\n"
((this 'get-x))
((this 'get-y))
z))))
((get-z (lambda () z))
(plus (lambda (p)
(print-this)
(let ((r ((this 'point-2d:plus) p)))
(point-3d ((r 'get-x))
((r 'get-y))
(+ z ((p 'get-z)))))))))
(let ((p1 (point-3d 1 2 3))
(p2 (point-3d 3 4 5)))
(let ((p3 ((p1 'plus) p2)))
(format *stdout* "x:~A, y:~A, z:~A\n"
((p3 'get-x))
((p3 'get-y))
((p3 'get-z)))))
-> x=1, y=2, z=3
-> x=1, y=2
-> x:4, y:6, z:8
ここで this は自分自身の連想配列を示し、基底クラスの公開メンバにアクセスするために使用する。
また (this 'point-2d:plus) って呼び出しがあるけど、これは基底クラス point-2d の公開メンバ plus を示している。公開メンバは「クラス名:メンバ名」という名前でも参照できるのだ。
あと、point-3d の引数で _x _y と先頭にアンダーバーをつけているのがあるけど、これらは基底クラスに引き渡す値で point-3d のメンバ関数から直接参照してはいけないため z と区別している。
さらに、メソッドの呼び出しを簡単にするため以下のマクロを追加する。
(define-macro (@ inst meth . args)
`((,inst (quote ,meth)) ,@args))
使用例は、
(let ((p1 (point-3d 1 2 3))
(p2 (point-3d 3 4 5)))
(let ((p3 (@ p1 plus p2)))
(format *stdout* "x:~A, y:~A, z:~A\n"
(@ p3 get-x)
(@ p3 get-y)
(@ p3 get-z))))
加えて、メソッドをより簡単に記述できるよう、define-classを以下のように変更。あと、クラス名の取得とインスタンスの確認の機能も追加する。
(define-macro (define-class constructor base privates publics)
(let ((f (lambda (bind)
(let ((name (car bind)))
(if (pair? name)
`(,(car name) (lambda ,(cdr name) ,@(cdr bind)))
bind)))))
(let ((class-name (symbol->string (car constructor)))
(privates (map f privates))
(publics (map f publics)))
`(define ,constructor
(let ((this ,(if base base '(hash-table))))
(set! (this #f) ,(if base
`(cons ,(car constructor) (this #f))
`(list ,(car constructor))))
(letrec* ,(append privates publics)
,@(map (lambda (public)
(let* ((name (car public))
(name2 (string->symbol
(string-append class-name ":"
(symbol->string name)))))
`(begin
(set! (this (quote ,name)) ,name)
(set! (this (quote ,name2)) ,name))))
publics)
this))))))
(define-macro (@ inst meth . args)
`((,inst (quote ,meth)) ,@args))
(define-macro (class inst)
`(car (,inst #f)))
(define-macro (instance? inst name)
`(and (hash-table? ,inst) (memq ,name (,inst #f))))
使用例は、
(define-class (point-2d x y)
#f
(((print-this)
(format *stdout* "x=~A, y=~A\n" (get-x) (get-y))))
(((get-x) x)
((get-y) y)
((plus p)
(begin
(print-this)
(point-2d (+ x (@ p get-x))
(+ y (@ p get-y)))))))
(let ((p (point-2d 1 2)))
(class p) ; -> point-2d
(instance? p point-3d) ; -> #f
)
いじょう