(define *class-pool* ())

(define (sysoos!register-class name instance)
  (let ((a-assoc (assoc name *class-pool*)))
    (if (pair? a-assoc)
	(set-cdr! a-assoc instance)
	(set! *class-pool*
	      (cons (cons name instance)
		    *class-pool*)))))

(define (vector-fill target from source)
  (define (iter from to do-proc)
    (if (< from to)
	(let ()
	  (do-proc from)
	  (iter (+ 1 from) to do-proc))))
  (iter 0 (vector-length source) 
	(lambda (i)
	  (vector-set! target (+ from i) (vector-ref source i))))
  target)

(define (sysoos!find-method name object)
  ;;(display "Try to find ") (display name) (display " in ") (display object) (display "\n")
  (let* ((methods-and-class (sysoos!method-table-and-class-for object))
	 (methods           (car methods-and-class))
	 (class-instance    (cdr methods-and-class))
	 (a-proc            (assoc name methods)))
    ;;(display "Methods: ") (display methods) (newline)
    (if (pair? a-proc)
	(cdr a-proc)
	(let ((found ())
	      (supers (vector-ref class-instance 1)))
	  (while (and (null? found) (pair? supers))
		 (set! found (sysoos!find-method name (car supers)))
		 (set! supers (cdr supers)))
	  found))))


(define (sysoos!get-class name)
  ;;(display "Try to find class ") (display name)(newline)
  (let ((result (assoc name *class-pool*)))
    (if result
	(cdr result)
	(error "*** Can't find class named" name))))


(define (generic-method? proc)
  (procedure-property proc 'generic-method))

(define (oop-method? proc)
  (procedure-property proc 'oop-method?))

(define (sysoos!set-to-generic-method proc)
  (if (procedure? proc)
      (set-procedure-property! proc 'generic-method #t)))

(define (sysoos!method-table-and-class-for object)
  (cond ((and (vector? object)                ;; Vector
	      (>= (vector-length object) 2)   ;; of minimum size 2
	      (pair? (vector-ref object 0))   ;; with first and
	      (pair? (vector-ref object 1))   ;;   second elements as a pair
	 (cons (vector-ref object 0) object)) ;; seems to be an object.
	(#t ;; must be a intern (guile) object
	 (sysoos!method-table-and-class-for (sysoos!get-class-instance object)))))

(define (sysoos!get-class-instance object)
  (cond ((and (real? object) (not (integer? object)))
	 (sysoos!get-class 'float))
	((integer? object)
	 (sysoos!get-class 'integer))
	((number? object)
	 (sysoos!get-class 'number))
	((closure? object)
	 (sysoos!get-class 'closure))
	((procedure? object)
	 (sysoos!get-class 'procedure))
	((string? object)
	 (sysoos!get-class 'string-class))
	((char? object)
	 (sysoos!get-class 'char))
	((null? object)
	 (sysoos!get-class 'null))
	((pair? object)
	 (sysoos!get-class 'cons))
	;;(#t (error "Can't find class instance of " object))))
	(#t (sysoos!get-class 'object))))

(define (sysoos!define-method classname meth-name body)
  (sysoos!define-generic-method meth-name)
  (sysoos!core-define-method classname meth-name body))

(define (sysoos!core-define-method classname meth-name body)
  (let* ((class   (if (symbol? classname)
		      (sysoos!get-class classname)
		      (sysoos!get-class-instance classname)))
	 (methods (car (sysoos!method-table-and-class-for class)))
	 (a-assoc (assoc meth-name methods)))
    (if (pair? a-assoc)
	(set-cdr! a-assoc body)
	(vector-set! class 0 (cons (cons meth-name body)
				   methods)))))

(define (sysoos!system-proc? a-proc-name)
  (if (defined? a-proc-name)
      (let ((value (eval name)))
	(and (procedure? value)
	     (and (not (generic-method? value))
		  (not (oop-method? value)))))
      #f))
      
  
(define (sysoos!define-generic-method name)
  (let ((a-proc 
	 (lambda (object . args) 
	   ;;(display "Call of generic procedure ")(display (quote ,name))(newline)
	   (let ((a-proc (sysoos!find-method name object)))
	     ;;(display "a-proc: ") (display a-proc) (newline)
	     (if (null? a-proc)
		 (does-not-understand object name args)
		 ;;(error "Kann in " object " keine Methode mit Namen " name " finden.")
		 (apply a-proc object args))))))
    (sysoos!make-global-with name a-proc)
    (sysoos!set-to-generic-method a-proc)
    a-proc))


(define (sysoos!make-global-with name value)
  (if (defined? name)
      (let ((value (eval name)))
	(if (or (not (procedure? value))
		(and (procedure? value)
		     (and (not (generic-method? value))
			  (not (oop-method? value)))))
	    (cond ((procedure? value)
		   (sysoos!core-define-method 'object name value)
		   (display "*** Define default object method ")
		   (display name) (newline)
		   )
		  (#t (display "*** Warning: Global ") 
		      (display name)
		      (display " already exists: ")
		      (display value)
		      (newline))))))
  (eval (list 'define-public name #t))
  (eval (list 'set! name value))
  (if (procedure? value)
      (set-procedure-property! value 'oop-method? #t)))


;; Classinstance: 
;; [ CLASSDESCRIPTOR
;;   SUPERS
;;   SLOT1
;;   SLOT2
;;   ...
;;   SLOTn

(define (sysoos!define-class classname slots supers)
  ;;; Some helpers
  (define (make-symbol-of . strings) 
    (string->symbol (apply string-append strings)))
  
  (let ((name-str        (symbol->string classname))
	(instance-length (+ 2 (length slots))))
    (let ((make-name      (make-symbol-of "sysoos!make-" classname))
	  (real-make-name (make-symbol-of "make-"     classname))
	  (clas-get-name  (make-symbol-of "class-"    classname))
	  (sysoos!make-proc 	
	   (lambda ()
	     (let ((v (make-vector instance-length ())))
	       (vector-set! v 0 (list (cons 'class-name (lambda (x) classname))))
	       (vector-set! v 1 (map sysoos!get-class supers))
	       ;;(display "Slots: ")(display (quote ,slots)) (newline)
	       (vector-fill v 2 
			    (apply vector 
				   (map (lambda (x)
					  (cond ((symbol? x) 
						 ())
						((and (pair? x) (pair? (cdr x)) 
						      (null? (cdr (cdr x))))
						 (cadr x))
						(#t ())))
					slots)))
	       v))))
      (sysoos!make-global-with make-name sysoos!make-proc)
      (sysoos!make-global-with
        real-make-name
	(lambda ()
	  (let* ((v (make-vector instance-length ()))
		 (class-object (sysoos!get-class classname)))
	    (vector-fill v 0 class-object))))
      (let ((class-instance (sysoos!make-proc)))
	(sysoos!register-class classname class-instance))
      (sysoos!make-global-with 
       clas-get-name
       (lambda ()
	 (sysoos!get-class classname))))))


(load "macros.scm")
(load "basic-classes.scm")
(load "object.scm")


;eof
