(module x-roos mzscheme
        (provide c-roos-new
                 c-roos-add-member
                 c-roos-new-super
                 c-roos-add-proxy
                 c-roos-call-member
                 c-roos-get-member
                 c-roos-supers-for-each
                 c-roos-class-is
                 c-roos-class
                 c-roos-is-object
                 object?
                 c-roos-set-this
                 c-roos-invalidate
                 c-roos-is-valid
                 c-roos-valid?
                 c-roos-id
                 roos-id
                 )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define ROOS-ID 0)

(define-syntax %error
  (syntax-rules ()
    ((%error a1 ...)
     (error (string-append "x-roos.scm:" (format "~a" a1) ...)))))

(define-struct %ROOS (object-type object-valid
                                  supers proxies
                                  public-members private-members
                                  class-name
                                  this-setter
                                  this
                                  id
                                  scache
                                  cache
                                  ))

;(define-syntax make-%ROOS
;  (syntax-rules ()
;    ((_ type valid supers proxies pu-mem pr-mem cln this-setter this id)
;     (vector '%ROOS type valid supers proxies pu-mem pr-mem cln this-setter this id))))

;(define-syntax defgs
;  (syntax-rules ()
;    ((_ g s index)
;     (begin
;       (define-syntax g
;         (syntax-rules ()
;           ((_ obj) (vector-ref obj index))))
;       (define-syntax s
;         (syntax-rules ()
;           ((_ obj v) (vector-set! obj index v))))
;       ))
;    ))

;(defgs %ROOS-object-type     set-%ROOS-object-type! 1)
;(defgs %ROOS-object-valid    set-%ROOS-object-valid! 2)
;(defgs %ROOS-supers          set-%ROOS-supers! 3)
;(defgs %ROOS-proxies         set-%ROOS-proxies! 4)
;(defgs %ROOS-public-members  set-%ROOS-public-members! 5)
;(defgs %ROOS-private-members set-%ROOS-private-members! 6)
;(defgs %ROOS-class-name      set-%ROOS-class-name! 7)
;(defgs %ROOS-this-setter     set-%ROOS-this-setter! 8)
;(defgs %ROOS-this            set-%ROOS-this! 9)
;(defgs %ROOS-id              set-%ROOS-id! 10)

;(define-syntax %ROOS?
;  (syntax-rules ()
;    ((_ obj)
;     (and (vector? obj) (= (vector-length obj) 11) (eq? (vector-ref obj 0) '%ROOS)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-syntax IS-ROOS-SUPER
  (syntax-rules ()
    ((_ obj)
     (eq? (%ROOS-object-type obj) 'super))))

(define-syntax IS-ROOS-OBJECT
  (syntax-rules ()
    ((_ obj)
     (%ROOS? obj))))

(define-syntax IS-ROOS-VALID
  (syntax-rules ()
    ((_ obj)
     (%ROOS-object-valid obj))))

(define-syntax CHECK-IS-NOT-SUPER
  (syntax-rules ()
    ((_ function object)
     (if (IS-ROOS-SUPER object)
	 (%error function ": cannot act on a !ROOS super object")))))

(define-syntax CHECK-IS-OBJECT
  (syntax-rules ()
    ((_ function object)
     (if (not (IS-ROOS-OBJECT object))
	 (%error function ": expects argument of type !ROOS")))))

(define-syntax CHECK-ROOS-VALID
  (syntax-rules ()
    ((_ function object)
     (if (not (IS-ROOS-VALID object))
	 (%error function ": object has been invalidated")))))

(define-syntax CHECK-IS-CLOSURE
  (syntax-rules ()
    ((_ function var)
     (if (not (procedure? var))
	 (%error function ": expects procedure here")))))

(define-syntax CHECK-IS-PUB-PRIV
  (syntax-rules ()
    ((_ function  var)
     (if (not (or (eq? var 'public) (eq? var 'private)))
	 (%error function ": expects 'public or 'private here")))))

(define-syntax CHECK-IS-MEMBER-NAME
  (syntax-rules ()
    ((_ function var)
     (if (not (symbol? var))
         (%error function ": expects a symbol here")))))

(define-syntax CHECK-IS-SYMBOL
  (syntax-rules ()
    ((_ a1 ...)
     (CHECK-IS-MEMBER-NAME a1 ...))))

(define-syntax ROOS-CHECKS-1
  (syntax-rules ()
    ((_ function (var (f1 ...)))
     (begin
       (f1 function var)
       ...))))

(define-syntax ROOS-CHECKS
 (syntax-rules ()
   ((_ function checks)
    #t)
;    (ROOS-CHECKS-1 function checks))
   ((_ function checks1 . (r1 ...))
    (begin
      #t
;      (ROOS-CHECKS-1 function checks1)
;      (ROOS-CHECKS function r1 ...)
      ))))
;     #t)))

(define (INVALID-THIS-SETTER . args)
  (%error "This setter not applicable"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (c-roos-new _class-name _this-setter _supers)
  (set! ROOS-ID (+ ROOS-ID 1))
  (make-%ROOS 'this #t
              _supers '()
              (list) (list)
              _class-name
              _this-setter
              #f
              ROOS-ID
              (make-hash-table) (make-hash-table)))

(define (c-roos-new-super object)
  (ROOS-CHECKS 'c-roos-new-super
               (object (CHECK-IS-OBJECT CHECK-ROOS-VALID CHECK-IS-NOT-SUPER)))

  (let ((super (c-roos-new (%ROOS-class-name object)
                           INVALID-THIS-SETTER
                           '())))
    (set-%ROOS-object-type! super 'super)
    (set-%ROOS-this! super object)
    super))


(define (c-roos-supers-for-each object closure)
  (ROOS-CHECKS 'c-roos-supers-for-each
               (object  (CHECK-IS-OBJECT CHECK-ROOS-VALID CHECK-IS-NOT-SUPER))
               (closure (CHECK-IS-CLOSURE)))

  (for-each closure (%ROOS-supers object))
  object)


(define (c-roos-add-member object type name closure)
  (ROOS-CHECKS 'c-roos-add-member 
	       (object  (CHECK-IS-OBJECT CHECK-ROOS-VALID CHECK-IS-NOT-SUPER))
	       (type    (CHECK-IS-PUB-PRIV))
	       (name    (CHECK-IS-MEMBER-NAME))
	       (closure (CHECK-IS-CLOSURE)))
  (if (eq? type 'public)
      (set-%ROOS-public-members! object (cons (cons name closure) (%ROOS-public-members object)))
      (set-%ROOS-private-members! object (cons (cons name closure) (%ROOS-private-members object))))
  object)


(define (c-roos-add-proxy object object-to-proxy)
  (ROOS-CHECKS 'c-roos-add-proxy
	       (object (CHECK-IS-OBJECT CHECK-ROOS-VALID CHECK-IS-NOT-SUPER))
	       (object-to-proxy
		       (CHECK-IS-OBJECT CHECK-ROOS-VALID CHECK-IS-NOT-SUPER)))

  (set-%ROOS-proxies! object (cons object-to-proxy (%ROOS-proxies object)))
  object)


(define (c-roos-false) #f)

(define (c-roos-find-member object name only-in-supers)

  (define (c-roos-find-in-objlist supers name)
    (if (null? supers)
        #f
        (let ((member (c-roos-find-member (car supers) name #f)))
          (if (eq? member #f)
              (c-roos-find-in-objlist (cdr supers) name)
              member))))

  (let ((m (if only-in-supers 
               (hash-table-get (%ROOS-scache object) name c-roos-false)
               (hash-table-get (%ROOS-cache object) name c-roos-false))))
    (if m
        m
        (let ((member (if only-in-supers
                          #f
                          (let ((pub (assq name (%ROOS-public-members object))))
                            (if (eq? pub #f)
                                (let ((priv (assq name (%ROOS-private-members object))))
                                  (if (not (eq? priv #f))
                                      (%error 'c-roos-find-member ":member function " name " is private (object of class " (c-roos-class object) ")")
                                      #f))
                                pub)))))

          (if (eq? member #f)
              (let ((member (c-roos-find-in-objlist (%ROOS-supers object) name)))
                (if (eq? member #f)
                    (c-roos-find-in-objlist (%ROOS-proxies object) name)
                    (begin
                      (hash-table-put! (if only-in-supers (%ROOS-scache object) (%ROOS-cache object)) name member)
                      member)))
              (begin
                (hash-table-put! (if only-in-supers (%ROOS-scache object) (%ROOS-cache object)) name (cdr member))
                (cdr member))))
        )))

(define (c-roos-call-member object name . args)
  (ROOS-CHECKS 'c-roos-call-member
               (object (CHECK-IS-OBJECT CHECK-ROOS-VALID))
               (name   (CHECK-IS-MEMBER-NAME)))

  (let ((member (if (IS-ROOS-SUPER object)
                    (c-roos-find-member (%ROOS-this object) name #t)
                    (c-roos-find-member object name #f))))
    (if (eq? member #f)
        (%error 'c-roos-call-member (format ": cannot find member ~a for object of type ~a" name (c-roos-class object)))
        (apply member args))))



(define (c-roos-get-member object name)
  (ROOS-CHECKS 'c-roos-get-member
               (object (CHECK-IS-OBJECT CHECK-ROOS-VALID))
               (name   (CHECK-IS-MEMBER-NAME)))

  (let ((member  (if (IS-ROOS-SUPER object)
                     (c-roos-find-member (%ROOS-this object) name #t)
                     (c-roos-find-member object name #f))))
    (if (eq? member #f)
        (%error 'c-roos-call-member ": cannot find member " name " for object of class " (c-roos-class object))
        member)))



(define (c-class-is-intern object class-name)

  (define (g supers class-name)
    (if (null? supers)
        #f
        (if (c-class-is-intern (car supers) class-name)
            #t
            (g (cdr supers) class-name))))

  (if (eq? (%ROOS-class-name object) class-name)
      #t
      (g (%ROOS-supers object) class-name)))


(define (c-roos-class-is object class-name)
  (ROOS-CHECKS 'c-roos-class-is
               (object (CHECK-IS-OBJECT CHECK-ROOS-VALID))
               (class-name (CHECK-IS-SYMBOL)))

  (c-class-is-intern (if (IS-ROOS-SUPER object)
                         (%ROOS-this object)
                         object)
                     class-name))


(define (c-roos-is-object obj) (IS-ROOS-OBJECT obj))
(define (object? obj)          (IS-ROOS-OBJECT obj))

(define (c-roos-is-valid object)
  (ROOS-CHECKS 'c-roos-is-valid
	       (object (CHECK-IS-OBJECT)))

  (IS-ROOS-VALID (if (IS-ROOS-SUPER object) 
		     (%ROOS-this object)
		     object)))

(define c-roos-valid? c-roos-is-valid)

(define (c-roos-invalidate object)
  (ROOS-CHECKS 'c-roos-invalidate
               (object (CHECK-IS-OBJECT CHECK-ROOS-VALID)))
  (set-%ROOS-supers! object '())
  (set-%ROOS-proxies! object '())
  (set-%ROOS-this-setter! object #f)
  (set-%ROOS-public-members! object #f)
  (set-%ROOS-private-members! object #f)
  (set-%ROOS-object-valid! object #f)
  (set-%ROOS-scache! object #f)
  (set-%ROOS-cache! object #f))

(define (c-roos-class object)
  (ROOS-CHECKS 'c-roos-class
	       (object (CHECK-IS-OBJECT)))

  (if (IS-ROOS-SUPER object)
      (set! object (%ROOS-this object)))

  (ROOS-CHECKS 'c-roos-class
	       (object (CHECK-ROOS-VALID)))

  (let ((super-name-list (map c-roos-class (%ROOS-supers object))))
    (list (%ROOS-class-name object) super-name-list)))


(define (c-roos-set-this object this)

  (define (g supers)
    (if (null? supers)
        object
        (begin
          (c-roos-set-this (car supers) this)
          (g (cdr supers)))))

  (ROOS-CHECKS 'c-roos-set-this
               (object (CHECK-IS-OBJECT CHECK-IS-NOT-SUPER CHECK-ROOS-VALID))
               (this   (CHECK-IS-OBJECT CHECK-IS-NOT-SUPER CHECK-ROOS-VALID)))
  ((%ROOS-this-setter object) this)
  (g (%ROOS-supers object)))


(define (roos-id object)
;  object)
  (%ROOS-id object))

(define c-roos-id  roos-id)


) ; end of module