tinyclos

Scheme でも CLOS が使える。tinyclos 。1992 に Xerox の人が書いている。たぶんThe Art of the Metaobject Protocol の作者。
読んで解説を書いてる人がいる。

http://practical-scheme.net/wiliki/wiliki.cgi?Scheme%3ATinyCLOS

複雑そうなのに 1000 行に満たない。さっそく使ってみる。まずは chicken にインストール。chicken-install tinyclos でインストール完了。簡単。

(use tinyclos)

(define-class <line-buffer> ()
  (line-n lbuf w-pos r-pos))

(add-method
  initialize
  (make-method
    (list <line-buffer>)
    (lambda (call-next-method pos initargs)
      (let ((line-n (get-keyword 'line-n initargs (lambda () 1920))))
        (for-each
          (lambda (slot-name-v)
            (let* ((ln-flag (list? slot-name-v))
                   (slot-name (if ln-flag (car slot-name-v) slot-name-v))
                   (value (if ln-flag
                            (cadr slot-name-v)
                            (get-keyword slot-name initargs (lambda () 0)))))

              (slot-set! pos slot-name value)))
          `((line-n ,line-n)
            (lbuf ,(make-vector line-n))
            w-pos
            r-pos))))))

ラインバッファみたいなのができた。ごちゃごちゃ書いてるけどこれは初期化処理を書いているだけ。実際の read/write を書いてみる。

;----------------------------------------------------------------
(define-generic show)
(define-generic read-lbuf)
(define-generic write-lbuf)

;----------------------------------------------------------------
(define-method (read-lbuf (lbuf <line-buffer>))
  (let ((w-pos (slot-ref lbuf 'w-pos))
        (r-pos (slot-ref lbuf 'r-pos)))

    (assert (>= w-pos r-pos))
    (if (= w-pos r-pos) #f
        (begin
          (set! (slot-ref lbuf 'r-pos) (+ r-pos 1))
          (vector-ref (slot-ref lbuf 'lbuf) r-pos)))))
;----------------------------------------------------------------
(define-method (write-lbuf (lbuf <line-buffer>) data)
  (let ((w-pos (slot-ref lbuf 'w-pos))
        (r-pos (slot-ref lbuf 'r-pos))
        (line-n (slot-ref lbuf 'line-n)))

    (assert (>= w-pos r-pos))
    (set! (vector-ref (slot-ref lbuf 'lbuf) w-pos) data)
    (let ((new-w-pos (+ w-pos 1)))
      (set! (slot-ref lbuf 'w-pos)
            (if (= line-n new-w-pos) 0 new-w-pos)))
    (assert (not (= (slot-ref lbuf 'w-pos) r-pos)))))
    ;w-pos))

ついでに表示ルーチンも書く。

;----------------------------------------------------------------
(define-method (show (lbuf <line-buffer>) . remain-args)
  (let ((v (slot-ref lbuf 'lbuf))
        (delimitor "")
        (end-n (if (null? remain-args) 16 (car remain-args)))
        (line-n (slot-ref lbuf 'line-n)))
    (letrec ((show-one
               (lambda (n)
                 (if (>= n end-n) #f
                     (if (>= n line-n) #f
                         (let ((elm (vector-ref v n)))
                           (if (number? elm)
                               (begin
                                 (print* delimitor)
                                 (print* elm)
                                 (set! delimitor " ")
                                 (show-one (+ n 1)))
                               #t)))))))
    (print* "[")
    (if (not (show-one 0))
        (print* " ..."))
    (print "]"))))

なんとなくできた。print-object に show をくっつけてみる

(define-method (print-object (lbuf <line-buffer>) #!optional (port ##sys#standard-output)) (show lbuf))

実行。

(define lbuf (make <line-buffer> 'line-n 100))
(define fn (lambda (n) (if (= n 0 ) #t (begin (write-lbuf lbuf n) (fn (- n 1))))))
(fn 3)
(fn 20)

print-object 実行

#;121> (print-object lbuf)
[3 2 1 20 19 18 17 16 15 14 13 12 11 10 9 8 ...]

おー C++ での << への対応の複雑さは何だったのだ。しかも 1992 年にこれができている。この 23年間は何だったのだ～～～～って感じ。