
(define-method object supers ()
  (sysoos!supers (class-instance self)))

(define-method object class-instance ()
  (cdr (sysoos!method-table-and-class-for self)))

(define-method object method-table ()
  (car (sysoos!method-table-and-class-for self)))

(define-method object method-named (name)
  (let ((method (sysoos!find-method name self)))
    (if (null? method)
	#f
	method)))

(define-method object sys!define-method (name body)
  (sysoos!define-method self name body))

(define-method object class-named ()
  (sysoos!get-class self))

(define-method object responds-to? (name)
  (if (method-named self name)
      #t 
      #f))

(define-method object does-not-understand (name args)
  (mdisplay "*** Error: Object " self " does not understand " name  
	    " with args " args)
  (newline)
  (backtrace)
  )

(define-method object does-not-understand-super (name args)
  (mdisplay "*** Error: Object " self " does not understand super " name  
	    " with args " args)
  (newline)
  (backtrace)
  )

(define-method object show-on (port)
  (display self port))

(define-method object mdisplay args
  (for-each (lambda (x) (show-on x (current-output-port)))
	    (cons self args)))

(define-method object for-super-classes (do-proc)
  (for-each do-proc (supers self)))

(define-method object print-ancestry-helper (n port)
  (for-super-classes self
		     (lambda (super)
		       (print-ancestry-helper super (+ 2 n) port)
		       (let ((str (make-string n)))
			 (string-fill! str (string-ref " " 0))
			 (display str))
		       (display "  ")
		       (display (class-name super))
		       (newline))))

(define-method object print-ancestry ()
  (print-ancestry-helper self 0 (current-output-port))
  (display (class-name self))
  (newline))

(define-method object oos!direct-clone (methods supers n-slots)
  "Create a clone with methodtable methods and supers SUPERS and 
n-slots slots."
  (mdisplay "Going to sysoos!clone " self)(newline)
  (sysoos!clone (class-instance self) methods supers n-slots))

(define-method object oos!simple-clone (n-slots)
  "Create a clone n-slots slots."
  (sysoos!clone (class-instance self) 
		(method-table self)
		(supers self)
		n-slots))

 
(define-method object oos!fullclone ()
  "Create a clone of self with clones of supers."
  (let ((supers-clone (map oos!fullclone (supers self))))
    (oos!direct-clone self (method-table self) supers-clone #f)))

(define-method object super (method-name . args)
  (let ((a-proc (sysoos!find-super-method method-name self)))
    ;;(display method-name) (display " ") (display method-name)
    ;;(display "a-proc: ") (display a-proc) (newline)
    (if (null? a-proc)
	;;(does-not-understand-super self name args)
	(error "Kann in " self " keine Methode mit Namen " name " finden.")
	(apply a-proc self args))))


;;eof
