pseudo-oop

;; 総称プロシージャ用連想リスト
(define generic-proc '())

;; クラス変数用連想リスト
(define class-vars-alist '())

;; クラス定義用マクロ
(define-syntax define-class
  (syntax-rules ()
    ((_ class (inst-var ...) 
        ((class-var class-val) ...) 
        (method arg body ...) ...)
     (begin
       (set! class-vars-alist 
             (cons `(class ((class-var . ,class-val) ...)) 
                   class-vars-alist))
       (for-each ensure-generic-proc '(method ...))
       (define (class inst-var ...)
         (lambda (message)
           (case message
             ((method) (lambda arg body ...))
             ...)))))))

(define (get-method object message)
  (object message)) 

(define (ensure-generic-proc message)
  (if (assq message generic-proc)
      #f
      (let ((proc (lambda (object . args)
                    (apply (get-method object message) args))))
        (set! generic-proc 
              (alist-cons message proc generic-proc)))))

(define-syntax get-class-var
  (syntax-rules ()
    ((_ class var)
     (cdr (assq 'var 
                (cadr (assq 'class class-vars-alist)))))))

(define-syntax class-var-set!
  (syntax-rules ()
    ((_ class var val)
     (let ((alist 
            (alist-cons 'var val 
                        (alist-delete 'var 
                                      (cadr (assq 'class class-vars-alist))))))
       (set! class-vars-alist 
             (cons `(class ,alist) 
                   (alist-delete 'class class-vars-alist)))))))

;; メソッド定義用マクロ
(define-syntax define-method
  (syntax-rules ()
    ((_ method)
     (define method (cdr (assq 'method generic-proc))))))