oo:make-object   scheme

;
; oo:make-object
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  Basic structure for OO programming
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define oo:make-object
   (lambda ()
      (let* ((klassname '<object>)
             (super #f)
             (isa (lambda (t)
                     (if (equal? t klassname)
                         #t
                         (if super
                             (super 'isa t)
                             #f))))
             (dispatch (lambda (msg methods)
                          (if (assoc msg methods)
                              (cdr (assoc msg methods))
                              (begin (print-error 'No 'such 'method) (error "")))))
             (get-method (lambda (msg) (cdr (assoc msg methods))))
             (add-method (lambda (name closure) ;; for mixings
                            (set! methods (cons (cons name closure) methods)) #t))
             (get-methods (lambda () methods))
             (printer (lambda () (print "object")))
             (methods (list (cons 'isa isa)
                            (cons 'get-method get-method) (cons 'add-method add-method)
                            (cons 'dispatch dispatch) (cons 'get-methods get-methods)))
             (self (lambda (msg . args)
                      (apply sys:dynamic-call
                             ((cdr (assoc 'dispatch methods)) msg methods)
                             args))))
         self)))