

(define (sysoos!print-oops-type-static obj port)  ; unused args: depth length style table)
  (sysoos!print-oops-type obj port))

(define (sysoos!print-oops-type obj port)  ; unused args: depth length style table)
  (display "#<OBJECT " port)
  (display (class-name obj) port)
  (display " (" port)
  (for-each (lambda (x) 
	      (display (class-name x) port)
	      (display " " port))
	    (struct-ref obj 1))
  (display ") METHODS: " port)
  (display (length (struct-ref obj 0)) port)
  (display " " port)
  (display (struct-ref obj 2) port)
  (display ">" port))


(define sysoos!record-type 
  (make-record-type 'oos-object 
		    '(methods supers values)
		    sysoos!print-oops-type-static))

(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-vector)
  (define (iter from to do-proc)
    (if (< from to)
	(let ()
	  (do-proc from)
	  (iter (+ 1 from) to do-proc))))
  (iter 0 (vector-length source-vector)
	(lambda (i)
	  (vector-set! target (+ from i) (vector-ref source-vector 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 (struct-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!find-super-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))
	 (class-instance    (cdr methods-and-class)))
    (let ((found ())
	  (supers (struct-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 (struct? object)                ;; Struct
	      (eq? (record-type-descriptor object) sysoos!record-type))
	 (cons (struct-ref object 0) object)) ;; seems to be a struct; return object himself as clas instance
	(#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))
	((symbol? object)
	 (sysoos!get-class 'symbol))
	((char? object)
	 (sysoos!get-class 'char))
	((null? object)
	 (sysoos!get-class 'null))
	((pair? object)
	 (sysoos!get-class 'cons))
	((vector? object)
	 (sysoos!get-class 'vector))
	;;(#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)
	(let ((a-list (struct-ref class 0)))
	  (if (null? a-list)
	      (struct-set! class 0 (list (cons meth-name body)))
	      (set-cdr! a-list 
			(cons (cons meth-name body)
			      (cdr a-list))))))))
	    
  
(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)
  ;;(display "Global ")
  ;;(display name)
  ;;(display "\n")
  (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 (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 ((record-constructor sysoos!record-type)
		       () () (make-vector instance-length ()))))
	       (struct-set! v 0 (list (cons 'class-name (lambda (x) classname))))
	       (struct-set! v 1 (map sysoos!get-class supers))
	       ;;(display "Slots: ")(display (quote ,slots)) (newline)
	       (vector-fill (struct-ref v 2)
			    0
			    (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 ((record-constructor sysoos!record-type)
	;;	     () () (make-vector instance-length ())))
	;;	 (class-object (sysoos!get-class classname)))
	;;    (struct-set! v 0 (struct-ref class-object 0))
	;;    (struct-set! v 1 (struct-ref class-object 1))
	;;    v
	;;    )))
      (let ((class-instance (sysoos!make-proc)))
	(sysoos!register-class classname class-instance)
	(sysoos!make-global-with 
	 clas-get-name
	 (lambda ()
	   (sysoos!get-class classname)))
	class-instance))))

(define (sysoos!clone who methods supers n-slots)
  (display "sysoos!clone: ") (display n-slots)(newline)
  (let* ((new-object ((record-constructor sysoos!record-type) () () ()))
	 (length     (or n-slots (vector-length (struct-ref who 2))))
	 (source-length (vector-length (struct-ref who 2)))
	 (old-values (struct-ref who 2))
	 (values     (make-vector length)))
    (struct-set! new-object 0 (or methods (struct-ref who 0)))
    (struct-set! new-object 1 (or supers (struct-ref who 1)))
    (struct-set! new-object 2 values)
    (do ((index 0 (+ index 1)))
	((= index length))
      (vector-set! values index 
		   (if (< index source-length)
		       (vector-ref old-values index)
		       ())))
    new-object))

(define (sysoos!methods object)
  (struct-ref object 0))

(define (sysoos!supers object)
  (struct-ref object 1))

(define (sysoos!values object)
  (struct-ref object 2))

(define (sysoos!set-slot o n v)
  (vector-set! (sysoos!values o) n v))

(define (sysoos!get-slot o n)
  (vector-ref (sysoos!values o) n))

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

(debug-enable 'backtrace)
(display ";; Example\n")
(display ";; (set! rr (new (class-rope) 10))\n")
(display ";; (add rr 7)\n")
(display ";; (add rr 8)\n")
(display ";; (add rr 9)\n")

(display ";;; ready\n")

;eof
