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
  )

いじょう