;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; $Id: roos-internal.scm,v 1.2 2006/05/20 14:45:20 hoesterholt Exp $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; $Log: roos-internal.scm,v $
; Revision 1.2  2006/05/20 14:45:20  hoesterholt
; Removed debug displays
;
; Revision 1.1.1.1  2006/05/20 11:40:11  hoesterholt
; ROOS Object System
;
; Revision 1.1.2.5  2006/05/20 11:24:17  HansOesterholt
; no message
;
; Revision 1.1.2.4  2006/02/12 23:23:36  HansOesterholt
; - We need to remove the display statements of roos
;
; Revision 1.1.2.2  2006/02/10 15:18:56  HansOesterholt
; *Class hierarchy can now be automatically generated
;
; Revision 1.1.2.1  2006/02/08 23:19:53  HansOesterholt
; Extending roos with spod, misc utils, etc.
;
; Revision 1.38.2.13  2006/02/04 23:00:36  HansOesterholt
; * Some small modifications have been made in ROOS to
;   permit the change of a ROOS class to a new ROOS class.
; * This has been done to facilitate Persistent ROOS.
;
; Revision 1.38.2.12  2006/02/03 23:41:54  HansOesterholt
; Changed roos documentation stuff to
; be better towards documentation.
;
; It is now possible to provide a procedure
; to a member definition. This procedure will then
; be called with the complete member definition.
;
; This procedure must return a list of member definition
; and documentation.
;
; Revision 1.38.2.11  2006/02/02 23:56:43  HansOesterholt
; Roos documentation is quite extensive now.
;
; Revision 1.38.2.10  2006/02/01 21:42:24  HansOesterholt
; spod generation is complete now. Classes can be
; documented inline
;
; Revision 1.38.2.9  2006/01/31 22:57:32  HansOesterholt
; Roos / spod documentation is now maybe a fact
;
; Revision 1.38.2.8  2006/01/30 23:56:40  HansOesterholt
; - Roos is being extended with SPOD documentation
;
; Revision 1.38.2.7  2006/01/02 21:03:31  HansOesterholt
; no message
;
; Revision 1.38.2.6  2005/12/30 00:25:17  HansOesterholt
; - ROOS Manual is OK now.
; - Next. Deliver a PLaNET Package?
;
; Revision 1.38.2.5  2005/12/28 22:55:03  HansOesterholt
; Made roos ready for PLT distribution
;
; Revision 1.38.2.4  2005/11/22 22:41:46  HansOesterholt
; Added a 'roos-dispatch' procedure to be able to
; dispatch functions as symbols, i.e.
;
; (roos-dispatch object 'function a1 ...)
;
; instead of
;
; (-> object function a1 ..)
;
; Revision 1.38.2.3  2005/11/06 17:35:09  HansOesterholt
; ROOS has been fully reprogrammed for mzscheme.\nA new type "#roos" has been made,\nand the main administrative functions have been recoded in C,\nwhich makes ROOS a lot faster.
;
; Revision 1.38.2.2  2005/11/06 11:21:24  HansOesterholt
; *** empty log message ***
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(module roos-internal mzscheme
	(require "c-roos.scm")
	(require "spod-roos.scm")
	(require (lib "list.ss" "mzlib"))


(define (displayp . args)
  (define (f l)
    (if (null? l)
	(newline)
	(begin
	  (display (car l))
	  (f (cdr l)))))
  (f args))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;=head1 ROOS implementation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;=head2 Info
;
;S<C<Author(s):>> Hans Oesterholt-Dijkema (hansatelementalprogrammingdotorgextension).E<lb>
;S<C<Copyright:>> (c) 2004/2005.E<lb>
;S<C<License  :>> LGPL
;S<C<File     :>> roos.scm $Revision: 1.2 $;
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;=head2 Error handling
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
;The internal function C<%roos-raise> raises an error situation, if
;possible, within the scheme variant, or else, displays an
;error to the current output port.
;
;=verbatim scm,8
(define (%roos-raise . args) 
  (let ((msg (apply string-append args)))
    (error msg)
))
;=verbatim
;
;The %roos-invalid function will raise an error, after an object
;has been invalidated by roos-cleanup, or (-> obj roos-cleanup)
;
;=verbatim scm,8
(define (%roos-invalid . args)
  (%roos-raise "This object has been invalided"))
;=verbatim
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;=head2 Storage
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
;This section implements storage facilities for ROOS.
;The implementation differs for different scheme dialects.
;For performance reasons, a hash is being used if possible.
;In all other cases, a list implementation of the storage
;is used.
;
;The storage interface stores (item, value) pairs in a
;container, which can be a hash or a list, depending
;on the scheme variant.
;
;To create a container, the internal function C<%roos-make-container>
;is defined.
;
;=verbatim scm,8
(define-syntax %roos-make-container
  (syntax-rules ()
    ((_)
     (make-hash-table))))
;=verbatim
;
;To put (item value) pairs in a container, the C<%roos-put-container>
;function has been defined.
;
;=verbatim scm,8
(define-syntax %roos-put-container
  (syntax-rules ()
    ((_ C item value)
     (hash-table-put! C item value))))
;=verbatim
;
;A specialized function has been created to register
;functions for classes. These functions are registered
;with a type indicator (e.g. private or public).
;
;=verbatim scm,8
(define-syntax %roos-register-item
  (syntax-rules ()
    ((_ L type item value)
     (%roos-put-container L item (cons type value)))))
;=verbatim
;
;With the assoc function, the registed items can be
;retreived.
;
;=verbatim scm,8
(define-syntax %roos-assoc
  (syntax-rules ()
    ((%roos-assoc %m %members)
     (hash-table-get %members %m (lambda () #f)))))

(define-syntax %roos-remove
  (syntax-rules ()
    ((_ C item)
     (hash-table-remove! C item))))
;=verbatim end
;
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;=head2 Registering class definitions
;
;To register class definitions, a global container is
;defined. In this container, all class definitions
;are registered.
;
;I<This makes it undesirable to register classes locally
;within a closure (unless locally within a class definition)
;because they are referenced forever, and therefore will
;make those closures live forever>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
;=verbatim scm,8
(define %roos-class-definitions  (%roos-make-container))
(define %roos-class-symbols      (%roos-make-container))
(define %roos-symbols-classes    (%roos-make-container))
(define %roos-class-docs         (make-hash-table))
(define %roos-class-supers       (make-hash-table))

(define (roos-class-change from-sym from-class
			   to-sym to-class)
;  (display (format "~a ~a -> ~a ~a~%"
;		   from-sym from-class to-sym to-class
;		   ))
  ;; change definitions
  (%roos-put-container %roos-class-definitions to-class to-class)
  (%roos-remove %roos-class-definitions from-class)
  ;; change class symbols
  (%roos-put-container %roos-class-symbols to-class to-sym)
  (%roos-remove %roos-class-symbols from-class)
  ;; change symbols-classes
  (%roos-put-container %roos-symbols-classes to-sym to-class)
  (%roos-remove %roos-symbols-classes from-sym)
  ;; change %roos-class-docs
  (let ((current-doc (hash-table-get %roos-class-docs from-sym (lambda () (spod)))))
    (hash-table-put! %roos-class-docs to-sym current-doc)
    (hash-table-remove! %roos-class-docs from-sym))
  ;; change %roos-class-supers
  (let ((current-supers (hash-table-get %roos-class-supers from-sym 
					(lambda () (lambda () '())))))
    (hash-table-put! %roos-class-supers to-sym current-supers)
    (hash-table-remove! %roos-class-supers from-sym))
  )

(define (%roos-is-class? class)
  (let ((c (%roos-assoc class %roos-class-definitions)))
    (eq? c class)))

(define (%roos-get-supers class-sym)
  (hash-table-get %roos-class-supers 
		  class-sym 
		  (lambda () (lambda () '()))))
  

(define-syntax %roos-get-class-symbol 
  (syntax-rules ()
    ((_ class)
     (%roos-assoc class %roos-class-symbols))))

(define-syntax %roos-get-class-for-symbol
  (syntax-rules ()
    ((_ class-sym)
     (%roos-assoc class-sym %roos-symbols-classes))))


(define (%do-roos-register-class class classname)
  (begin
    (%roos-put-container %roos-class-definitions class class)
    (%roos-put-container %roos-class-symbols     class classname)
    (%roos-put-container %roos-symbols-classes   classname class)))

(define-syntax %roos-register-class
  (syntax-rules ()
    ((_ class)
     (%do-roos-register-class class 'class))))

(define-syntax %roos-register-class-name1
  (syntax-rules ()
    ((_ (%name . %arguments1))
     (%roos-register-class %name))
    ((_ (%name %arg1 . %arg2))
     (%roos-register-class %name))
    ((_ (%name args ...))
     (%roos-register-class %name))
    ((_ (%name))
     (%roos-register-class %name))))

(define-syntax %roos-register-class-name
  (syntax-rules ()
    ((_ %def)
     (%roos-register-class-name1 %def))
    ((_ %def . %no)
     (%roos-register-class-name1 %def))))

(define-syntax %roos-get-class-name1
  (syntax-rules ()
    ((_ (%name . %arguments1)) '%name)
    ((_ (%name %arg1 . %arg2)) '%name)
    ((_ (%name args ...)) '%name)
    ((_ (%name)) '%name)))

(define-syntax %roos-get-class-name
  (syntax-rules ()
    ((_ %def)
     (%roos-get-class-name1 %def))
    ((_ %def . %no)
     (%roos-get-class-name1 %def))))

(define-syntax %roos-get-class-def
  (syntax-rules ()
    ((_ %def)
     '%def)
    ((_ %def . %no)
     '%def)))

(define-syntax %roos-get-constructor-doc
  (syntax-rules ()
    ((_ (constructor d1 ...) body ...)
     (spod d1 ...))
    ((_ constructor body ...)
     (spod))
    ))

(define-syntax %roos-get-private-doc
  (syntax-rules ()
    ((_ (private d1 ...))
     (spod d1 ...))
    ((_ private)
     (spod))
    ))

(define-syntax %roos-get-public-doc
  (syntax-rules ()
    ((_ (public d1 ...))
     (spod d1 ...))
    ((_ public)
     (spod))
    ))
(define-syntax %roos-get-cleanup-doc
  (lambda (x)
    (syntax-case x (roos-doc)
      ((_ explicit-cleanup (roos-doc d1 ...) body ...)
       (syntax (spod d1 ...)))
      ((_ explicit-cleanup body ...)
       (syntax (spod))))
    ))


(define (%roos-add-doc-to-class name doc)
  (let ((curdoc (hash-table-get %roos-class-docs 
				name (lambda () (spod)))))
    (hash-table-put! %roos-class-docs
		     name (spod-merge curdoc doc))
    ))

(define (%roos-prepend-doc-to-class name doc)
  (let ((curdoc (hash-table-get %roos-class-docs 
				name (lambda () (spod)))))
    (hash-table-put! %roos-class-docs
		     name (spod-merge doc curdoc))
    ))

(define (%roos-get-class-derivatives myname)
  (let ((ds (make-hash-table)))
    (roos-map-classes (lambda (name cl)
			(let ((sups (hash-table-get %roos-class-supers name 
						    (lambda () (lambda () '())))))
			  (let ((sps (sups)))
			    (for-each (lambda (n) 
					(if (eq? n myname)
					    (hash-table-put! ds name name)))
				      sps)))))
    (hash-table-map ds (lambda (key value) key))))


(define callno 0)
(define (%roos-register-class-doc name namedef def cleanup global-doc supers privates publics)

  ;;; Guess the super classes by analysing the code
  ;;; that is used in the 'supers' section
  (define (get-supers supers)
    (let ((S (make-hash-table)))

      (define (find l)
	;(display (format "~a~%" l))
	(if (symbol? l)
	    (let ((c (%roos-get-class-for-symbol l)))
	      ;(display (format "~a ~a ~%" l c))
	      (if (not (eq? c #f))
		  (hash-table-put! S l l)))
	    (if (list? l)
		(if (null? l)
		    #t
		    (begin
		      (find (car l))
		      (find (cdr l))))
		#t)))

      (find supers)
      (let ((M (hash-table-map S (lambda (c0 c1) c0))))
;        (display (format "M=~a~%" M))
        M)))

  (define (reg-supers name sups)
    (hash-table-put! %roos-class-supers name sups))

  (define (get-spod-supers name)
    (let ((sups (hash-table-get %roos-class-supers name 
				(lambda () (lambda () '())))))
;      (display (format "get-spod-supers: ~a ~a~%" name (sups)))
      (spod-merge 
       (spod (class-supers (sups)))
       (let ((derives (%roos-get-class-derivatives name)))
	 (spod (class-derived derives))))))

  (let ((sups (lambda () (get-spod-supers name))))
;    (display (format "classdoc: ~a, ~a~%" callno supers))
    (set! callno (+ callno 1))
    (reg-supers name (lambda () (get-supers supers)))
    (hash-table-put! %roos-class-docs
		     name
		     (spod namedef
			   global-doc
			   sups
			   def
			   cleanup
			   privates
			   publics))))
		    
;=verbatim
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;=head2 Object administration and utility functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
;Functions are provided to find members, propagate the 'self'
;notice upward to super classes and do function application.
;
;With the C<%roos-find-member-in-supers> function, a function or
;member variable can be found in an instantiated object.
;
;=verbatim scm,8
(define (%roos-find-member-in-supers %supers %get-mem)
  (define (%find %supers)
    (if (null? %supers)
	'roos-not-found
	(let ((%member (((cadar %supers) '%find-member) %get-mem)))
	  (if (eq? %member 'roos-not-found)
	      (%find (cdr %supers))
	      %member))))
  (%find %supers))

(define %roos-find-member-in-proxies %roos-find-member-in-supers)
;=verbatim
;
;With the C<%roos-propagate-this> function, propagation of
;the notice of 'self' is provided to super classes.
;This function interacts with a function provided within
;the class self.
;
;=verbatim scm,8
(define (%roos-propagate-this %supers %this)
  (for-each 
   (lambda (%super)
     (begin
       (((cadr %super) '%propagate-this) %this)
       (((cadr %super) '%set-this) %this)))
   %supers))
;=verbatim
;
;The C<%roos-apply> function is used to do function
;application. However it only applies a function, if
;it's not a private one.
;
;=verbatim scm,8
(define (%roos-apply %mem . %args)
  (let* ((%type (car %mem))
	 (%func-or-var (cdr %mem)))
    (if (eq? %type 'private)
	'roos-private
	(cond
	 ((procedure? %func-or-var)
	  (apply %func-or-var %args))
	 (else
	  'roos-unexpected)))))
;=verbatim
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;=head2 Macros for class definitions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
;Internal macros for defining (parts of) a class are defined
;below.
;
;The C<%roos-def> macro wraps defines for  functions and
;variables.
;
;=verbatim scm,8
(define-syntax %roos-def-internal
  (syntax-rules ()
    ((_ (define (function . arguments1) body ...))
     (define (function . arguments1) body ...))
    ((_ (define (function arguments1 . arguments2) body ...))
     (define (function arguments1 . arguments2) body ...))
    ((_ (define (function arguments ...) body ...))
     (define (function arguments ...) body ...))
    ((_ (define (function argument) body ...))
     (define (function argument) body ...))
    ((_ (define variable argument))
     (define variable argument))))

(define-syntax %roos-def
  (syntax-rules ()
    ((_ ((define d1 ...) a1 ...))
     (%roos-def-internal (define a1 ...)))
    ((_ (define a1 ...))
     (%roos-def-internal (define a1 ...)))
    ))

(define-syntax %roos-def-doc-get-def
  (syntax-rules ()
    ((_ (function) body ...)              (list '(function)))
    ((_ (function . arguments) body ...)  (list '(function . arguments)))
    ((_ (function arg1 . arg2) body ...)  (list '(function arg1 . arg2)))
    ((_ (function arg1 ...) body ...)     (list '(function arg1 ...)))
    ((_ (function arg1) body ...)         (list '(function arg1)))
    ((_ variable value   )                'variable)
    ))
  
(define-syntax %roos-def-doc
  (syntax-rules ()
    ((_ ((define (d1 ...)) a1 ...))
     (let ((fdef (%roos-def-doc-get-def a1 ...)))
       (if (list? fdef)
	   (spod (member-function (car fdef) (d1 ...)))
	   (spod (member-var fdef (d1 ...))))))
    ((_ ((define F) a1 ...))
     (if (procedure? F)
	 (let ((fdef-doc (F 'a1 ...)))
	   (let ((fdef (car fdef-doc))
		 (doc  (cadr fdef-doc)))
	     (if (list? fdef)
		 (spod (member-function (car fdef) doc))
		 (spod (member-var fdef doc)))))
	 (let ((fdef (%roos-def-doc-get-def a1 ...)))
	   (if (list? fdef)
	       (spod (member-function (car fdef) F))
	       (spod (member-var fdef F))))))
    ((_ ((define d1 ...) a1 ...))
     (let ((fdef (%roos-def-doc-get-def a1 ...)))
       (if (list? fdef)
	   (spod (member-function (car fdef) d1 ...))
	   (spod (member-var fdef d1 ...)))))
    ((_ (define a1 ...))
     (spod))
    ))

(define-syntax %roos-body
  (syntax-rules ()
    ((_)
     (%roos-body #t))
    ((_ body ...)
     (begin body ...))))
;=verbatim
;
;The C<%roos-register> macro registers the with C<%roos-def>
;defined functions in a given container.
;
;=verbatim scm,8
(define-syntax %roos-register
  (syntax-rules ()
    ((%roos-register L type (define (function . arguments1) body ...))
     (c-roos-add-member L type 'function function))
    ((%roos-register L type (define (function arguments1 . arguments2) body ...))
     (c-roos-add-member L type 'function function))
    ((%roos-register L type (define (function arguments ...) body ...))
     (c-roos-add-member L type 'function function))
    ((%roos-register L type (define (function argument) body ...))
     (c-roos-add-member L type 'function function))
    ((%roos-register L type (define variable argument))
     (c-roos-add-member L type 'variable (lambda args
					   (if (not (null? args))
					       (set! variable (car args)))
					   variable)))))

(define-syntax %roos-register-member
  (syntax-rules ()
    ((_ a1 ...)
     (c-roos-add-member a1 ...))))
    
;=verbatim
;
;The C<%roos-class> macro is used to define a class. This macro
;is quite complex. It defines a procedure that returns a closure.
;
;The returned closure has a number of internal procedures to
;handle administrative tasks (like propagating and setting 'this',
;finding member functions in the class inheritance, calling
;member functions, etc.).
;
;The macro defines a number of containers and lists to keep
;member functions and super classes.
;
;The provided definitions in the 'this', 'supers', 'private',
;'public', 'constructor', 'explicit-cleanup' and 'body'
;parts of the C<%roos-class> are used
;to construct a closure definition that can be used to construct
;objects of the class to be defined.
;
;Because the 'this' part can optionally contain extra variable
;declarations, the whole thing becomes a complex closure.
;
;The order of construction is as follows: supers are constructed
;first in order of appearance. After that the construction part
;(the body) of defined class is executed.
;
;Macro definition:
;
;=verbatim scm,8
(define-syntax %roos-define-class
  (syntax-rules ()
    ((_ (%class-definition . %declarations) body)
     (define %class-definition body))))

(define-syntax %roos-declarations
  (syntax-rules ()
    ((_ (a) (body))
     body)
    ((_ (a . (p1 ...)) . (body))
     (let* (p1 ...)
       body))))

(define-syntax %roos-class
  (lambda (x)
    (syntax-case x (roos-doc)
		 ;(syntax-rules ()
    ((%roos-class
      ((doc  %spod1 ...)
       (this %class-definition ...) 
       (supers %class-instance1 ...)
       (%private %private-memberdef1 ...)
       (%public %memberdef1 ...)
       (%constructor %body ...)
       (%explicit-cleanup %clbody ...)))
;=verbatim
;
;The class definition consists of two parts. The definition
;of a new procedure with which new objects can be constructed,
;and the registration of the defined class.
;
;=verbatim scm,8
    (syntax
     (begin
;=verbatim
;
;The class definition follows. The '*this' closure will
;eventually be returned.
;
;=verbatim scm,8
	(%roos-define-class (%class-definition ...)
         (%roos-declarations (%class-definition ...) 
             (letrec ((*this
;=verbatim
;
;Define containers and needed administrative variables
;
;=verbatim scm,8
		     (let* ((this   #f)
			    (supers #f)
			    (%cobj  (c-roos-new (%roos-get-class-name %class-definition ...)
						(lambda (t) (set! this t))
						(list %class-instance1 ...))))
;=verbatim
;
;Define administrative procedures needed for objects.
;
;=verbatim scm,8
		       (define (roos-cleanup)
                         (let ((R (%roos-body %clbody ...)))
			   (c-roos-supers-for-each %cobj 
						   (lambda (obj)
						     (-> obj roos-cleanup)))
			   (c-roos-invalidate %cobj)
			   R))

		       (define (roos-add-proxy proxy-obj)
			 (c-roos-add-proxy %cobj proxy-obj)
			 this)

;=verbatim
;
;Define private members, public members and the constructor (using the body).
;
;=verbatim scm,8
		       (%roos-def %private-memberdef1)
		       ...
		       (%roos-def %memberdef1)
		       ...
		       (%roos-def (define (%construct) (%roos-body %body ...)))

; 		       (define (%this) this)
; 		       (define (%supers) supers)
;=verbatim
;
;register some administrative members that must be called from the outside
;of an object.
;
;=verbatim scm,8
		       (%roos-register-member %cobj 'public 'roos-cleanup roos-cleanup)
		       (%roos-register-member %cobj 'public 'roos-add-proxy roos-add-proxy)
;=verbatim
;
;register private, public members and constructor in the %members structure.
;
;=verbatim scm,8
		       (%roos-register %cobj 'private %private-memberdef1)
		       ...
		       (%roos-register %cobj 'public %memberdef1)
		       ...

		       (%roos-register %cobj 'public (define (%construct) (%roos-body %body ...)))
; 		       (%roos-register %cobj 'public (define (%this) this))
; 		       (%roos-register %cobj 'public (define (%supers) supers))
;=verbatim
;
;Set the 'supers' variable (later the 'this' variable will be set), to
;be able to call supers.
;
;=verbatim scm,8
		       (set! supers (c-roos-new-super %cobj))
;=verbatim
;
;The C<%call-member> function is returned to handle object calls.
;
;=verbatim scm,8
		       %cobj)))
;=verbatim
;
;'*this' is now defined, now handle some instantiation administration.
;Set the 'this' variable, propagate the 'this' variable to the super
;classes and call the constructor of the class.
;
;=verbatim scm,8
	       (let ((%object *this))
		 (c-roos-set-this %object %object)
		 (c-roos-call-member %object '%construct)
;=verbatim
;
;Return the pair C<('roos-this *this)>. The object has been instantiated.
;
;=verbatim scm,8
		 %object)
	       )))
;=verbatim
;
;Now the class has been defined. Register the class in the class register.
;
;=verbatim scm,8
       (%roos-register-class-name %class-definition ...)
;=verbatim
;
;And of course, put the documentation somewhere
;
;=verbatim scm,8
       (%roos-register-class-doc
        (%roos-get-class-name %class-definition ...)
        (spod (class-name (%roos-get-class-name %class-definition ...)))
        (spod (class-def  (%roos-get-class-def  %class-definition ...)
                          (%roos-get-constructor-doc %constructor %body ...)))
        (spod (class-cleanup (%roos-get-cleanup-doc %explicit-cleanup %clbody ...)))
        (spod (class-doc %spod1 ...))
        (list '%class-instance1 ...)
        (spod (class-private (%roos-get-private-doc %private) (%roos-def-doc %private-memberdef1) ...))
        (spod (class-public  (%roos-get-public-doc %public) (%roos-def-doc %memberdef1) ...)))
       ))))))
;=verbatim
;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;=head2 The interface macro for class definitions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
;C<r-class> defines the interface macro for class definitions.
;It's simply a wrapper around %roos-class. Does nothing
;interesting, but making C<explicit-cleanup> optional.
;
;=verbatim scm,8
(define-syntax def-class
  (lambda (x)
    (syntax-case x (roos-doc)
      ((_
	(this %this ...)
	(supers super1 ...)
	(private private1 ...)
	(public public1 ...)
	(constructor c1 ...))
       (syntax
	(def-class
	  (roos-doc  (spod))
	  (this %this ...)
	  (supers super1 ...)
	  (private private1 ...)
	  (public public1 ...)
	  (constructor c1 ...)
	  (explicit-cleanup #t))))
      ((_
	(roos-doc  %spod ...)
	(this %this ...)
	(supers super1 ...)
	(private private1 ...)
	(public public1 ...)
	(constructor c1 ...))
       (syntax 
	(def-class
	  (roos-doc %spod ...)
	  (this %this ...)
	  (supers super1 ...)
	  (private private1 ...)
	  (public public1 ...)
	  (constructor c1 ...)
	  (explicit-cleanup #t))))
      ((_
	(this %this ...)
	(supers super1 ...)
	(private private1 ...)
	(public public1 ...)
	(constructor c1 ...)
	(explicit-cleanup cln1 ...))
       (syntax
	(def-class
	  (roos-doc (spod))
	  (this %this ...)
	  (supers super1 ...)
	  (private private1 ...)
	  (public public1 ...)
	  (constructor c1 ...)
	  (explicit-cleanup cln1 ...))))
      ((_
	(roos-doc  %spod ...)
	(this %this ...)
	(supers super1 ...)
	(private private1 ...)
	(public public1 ...)
	(constructor c1 ...)
	(explicit-cleanup cln1 ...))
       (syntax
	(%roos-class
	 ((roos-doc %spod ...)
	  (this %this ...)
	  (supers super1 ...)
	  (private private1 ...)
	  (public public1 ...)
	  (constructor c1 ...)
	  (explicit-cleanup cln1 ...)))))
      )))
;=verbatim
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;=head2 Predicates
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
;C<object?> is an object predicate. It simply checks if
;an object is a list. If so, it checks wether the car of
;the object is C<'roos-this> or C<'roos-supers> and if
;the cadr of the object is a procedure. If so, it assumes
;that the list is indeed an instance of a roos class.
;
;I<Note that all roos objects are also lists. For each
;roos object (list? object) -> #t>. As redefinition of
;scheme primitives not always yields expected results,
;no attempt is made to redefine the C<list?> primitive,
;to exclude a variable that is an object from being a list.
;
;=verbatim scm,8
;=verbatim
;
;The C<class?> predicate checks if an object is part
;of the registered classes. It's simply a call to the
;earlier defined C<%roos-is-class?> procedure.
;
;=verbatim scm,8
(define (class? obj)
  (%roos-is-class? obj))
;=verbatim
;
;The C<class=?> predicate checks if an object 'obj' is of
;the class given by 'class', where 'class' is a symbol.
;Calling this function on any 'this' variable within an
;object, will yield true for all the classes, of which
;'obj' is made of, see also the C<class> function.
;
;=verbatim scm,8
(define (class=? obj class)
  (let ((s (if (class? class)
	       (%roos-get-class-symbol class)
	       (if (procedure? class)
		   '%roos-no-class-def
		   class))))
    (c-roos-class-is obj s)))
;=verbatim
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;=head2 Meta information
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
;The C<class> function gets all classes, an object 'obj'
;is made of.
;
;=verbatim scm,8
(define (class obj)
  (if (object? obj)
      (c-roos-class obj)
      #f))
;=verbatim
;
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;=head2 Calling members
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
;C<-E<gt>> calls a member of an object. Note: member
;variables are wrapped in a special function. See the
;C<%roos-register> macro earlier. Suppose a class has
;a public member variable 'm', with value 10, then
;this member variable
;is accessible as follows using '-E<gt>':
;
;=over 1
;
;C<(display (-E<gt> object m)) =E<gt> 10)>
;
;C<(-E<gt> object m (+ (-E<gt> object m) 5)) =E<gt> 15>
;
;=back
;
;=verbatim scm,8
(define-syntax ->
  (syntax-rules ()
    ((_ obj f)
     (c-roos-call-member obj 'f))
    ((_ obj f a1 ...)
     (c-roos-call-member obj 'f a1 ...))))

(define-syntax ->>
  (syntax-rules ()
    ((_ obj f)
     (c-roos-get-member obj 'f))))

(define (roos-dispatch obj f . args)
  (apply c-roos-call-member (cons obj (cons f args))))

;=verbatim
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;=head2 Calling members via generic macros
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
;Here a very simple generic "function" interface is
;given. Simply define a class member as generic,
;possibly renaming it at the outside, and call
;it on any object for which C<object?> returns true.
;
;It will translate the call C<(f object arg1 arg2 ...)>
;into C<(-> object f arg1 arg2 ...)>.
;
;=verbatim scm,8
(define-syntax %roos-generic-intern
  (syntax-rules ()
    ((_ object f)
     (-> object f))
    ((_ object f (a1 ...))
     (-> object f a1 ...))))

(define-syntax def-generic
  (syntax-rules ()
    ((_ generic-function)
     (def-generic generic-function generic-function))
    ((_ generic-function object-function)
     (define-syntax generic-function
       (syntax-rules ()
	 ((_ object) 
	  (%roos-generic-intern object object-function))
	 ((_ object . arguments)
	  (%roos-generic-intern object object-function arguments)))))))
;=verbatim
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;=head2 Roos cleanup
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
;C<roos-cleanup> or C<-E<lt>> can be used to call the default
;C<explicit-cleanup> member that can be used to cleanup an object explicitly.
;After roos-cleanup is called, an object is invalidated.
;See also L<Using ROOS|Manual and examples of ROOS>.
;You can test on an invalid object using C<roos-invalid?>.
;
;=verbatim scm,8
(define (roos-cleanup obj)
  (-> obj roos-cleanup))

(define-syntax -<
  (syntax-rules ()
    ((-< obj)
     (roos-cleanup obj))))

(define (roos-invalid? obj)
  (not (c-roos-valid? obj)))
;=verbatim
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;=head2 Roos add proxy
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
;A ROOS object can be a proxy for an other object. This is
;not the same as superclassing. It adds all public methods
;of the object to proxy for to the current object, but calls
;them in the object to proxy for.
;
;=verbatim scm,8
(define (roos-add-proxy obj obj-to-proxy-for)
  (-> obj roos-add-proxy obj-to-proxy-for))
;=verbatim
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;=head2 Roos Named Arguments
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
;C<named-argument> or C<=E<gt>> are there to process argument
;lists with named arguments.
;
;=verbatim scm,8
(define-syntax named-argument
  (syntax-rules ()
    ((_ name arglist)
     (named-argument name arglist #f))
    ((_ name arglist default-value)
     (let ((a (memq name arglist)))
        (if (eq? a #f)
            default-value
	    (if (null? (cdr a))
		'%roos-exists
		(cadr a)))))))

(define-syntax =>
  (syntax-rules ()
    ((_ a b)
     (named-argument a b))
    ((_ a b c)
     (named-argument a b c))))
;=verbatim
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;=head2 Roos version
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;=verbatim scm,8
(define (roos-version)
  (string->number "1.40"))
;=verbatim
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;=head2 Exported interface
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
;The exported interface consists of macros:
;C<def-class>, C<def-generic>, C<class?>, C<object?>,
;C<named-argument>, C<=E<gt>>
;and C<-E<gt>>. A couple of functions are exported:
;C<roos-version>, C<object?>, C<class?>, C<class=?>,
;C<roos-cleanup> and C<class>.
;
;=cut

; (define-syntax add-member
;   (syntax-rules ()
;     ((_ class this supers member-name function)
;      (let ((prev-class class))
;        (let ((newclass (lambda args
; 			 (let ((obj (apply prev-class args)))
; 			   (c-roos-add-member obj
; 					      'public
; 					      'member-name
; 					      (lambda args
; 						(let ((this (-> obj %this))
; 						      (supers (-> obj %supers)))
; 						  (apply function args))))
; 			   obj))))
;        (set! class newclass)
;        (%roos-register-class class))))))

(define (roos-class-doc class)
  (let ((s (if (class? class)
	       (%roos-get-class-symbol class)
	       (if (procedure? class)
		   '%roos-no-class-def
		   class))))
    (hash-table-get %roos-class-docs s (lambda () (list "")))))

(define (roos-class-name class)
  (if (symbol? class)
      class
      (%roos-get-class-symbol class)))

(define (roos-map-classes proc)
  (hash-table-map %roos-symbols-classes (lambda (sym class) (proc sym class))))


(define (roos-class-hierarchy . class-filter)

  (define (find-depth clh name)
    (let ((supers (hash-table-get clh name)))
      (if (null? supers)
	  0
	  (apply max (map (lambda (sup)
			    (+ 1 (find-depth clh sup)))
			  supers)))))


  (define (create-class-tree class cldh)
    (list class (map (lambda (cl) 
		       (create-class-tree cl cldh))
		     (hash-table-get cldh class (lambda () '())))))

  (let ((classes (if (null? class-filter) 
		     (roos-map-classes (lambda (name cl) cl))
		     (let ((f (car class-filter)))
		       (filter (lambda (e) e)
			       (roos-map-classes (lambda (name cl) 
						   (if (f name cl)
						       cl
						       #f)))))))
	(clh     (make-hash-table)))
    (for-each (lambda (cl)
		(let* ((name   (roos-class-name cl))
		       (supers ((%roos-get-supers name))))
;		  (display (format "name,supers: ~a ~a ~%" name supers))
		  (hash-table-put! clh name supers)))
	      classes)
    (let ((max-depth 0)
	  (cll       (make-hash-table)))

      (hash-table-for-each clh
			   (lambda (name cl) 
			     (let ((d (find-depth clh name)))
			       (hash-table-put! cll name d)
			       (set! max-depth (max d max-depth)))))

      (let ((zero-level-classes (map (lambda (dcl) (car dcl))
				     (filter (lambda (depth-name)
					       (= (cadr depth-name) 0))
					     (hash-table-map cll (lambda (name depth)
								   (list name depth))))
					     ))
	    (cldh               (make-hash-table)))
	(hash-table-for-each clh
			     (lambda (name sups)
;			       (display (format "name,sups: ~a ~a ~%" name sups))
			       (for-each (lambda (super)
					   (let ((derivs (hash-table-get cldh super (lambda () '()))))
					     (hash-table-put! cldh super (cons name derivs))))
					 sups)))
	
;	(hash-table-for-each cldh
;			     (lambda (name derivs)
;			       (display (format "~a ~a~%" name derivs))))
	
	(map (lambda (class)
		 (create-class-tree class cldh))
	     zero-level-classes)
	))))

(define (roos-class-hierarchy->spod hierarchy . name)

  (define (sort-classes L)

    (define (get-sym e)
      (if (symbol? e)
	  (symbol->string e)
	  (if (list? e)
	      (if (null? e)
		  ""
		  (get-sym (car e))))))

    (quicksort L (lambda (e1 e2)
		   (string-ci<? (get-sym e1) (get-sym e2)))))


  (define (make-hierarchy cl-h indent)
    (if (null? cl-h)
	(spod)
	(let ((cl (car cl-h)))
	  (if (symbol? cl)
	      (spod (s\\ (s%% (make-string (* indent 3) #\ )) (slink cl cl))
		    (make-hierarchy (cdr cl-h) (+ indent 1)))
	      (if (list? cl)
		  (map (lambda (cl)
			 (make-hierarchy cl indent))
		       (sort-classes cl-h))
		  (error "UNEXPECTED?" cl))))))

  (apply 
   ->spod
   (cons 
    (spod-merge (spod (s= "Class hierarchy"))
		(map (lambda (h)
		       (spod-nlnl h))
		     (make-hierarchy hierarchy 0)))
    name)))

;  (spod-merge spods)))


(define (roos->spod info class . see-also)
  (let ((name (roos-class-name class))
	(doc  (roos-class-doc  class)))
    (let ((fulldoc (spod (ssyn 'scm 8) 
			 doc 
			 (if (null? see-also) (spod-empty) (car see-also))
			 info)))
      (->spod fulldoc name))))



(define (roos-classes->spod class-filter hierarchy-name info . _see-also)
  (let ((classes (filter (lambda (cl) cl)
			 (roos-map-classes class-filter)))
	(see-also (spod-merge (spod (s= "See also")
				    (spod-nlnl
				     (let ((comma ""))
				       (map
					(lambda (link)
					  (let ((R (spod-merge (spod comma)
							       (if (list? link) 
								   (if (> (length link) 1)
								       (spod (slink (car link) (cadr link)))
								       (if (null? link)
									   (spod)
									   (spod (slink (car link)))))
								   (spod (slink link))))))
					    (set! comma ",")
					    R))
					(cons hierarchy-name _see-also))))))))
    (for-each (lambda (class)
		(roos->spod info class see-also))
		classes)
    (roos-class-hierarchy->spod (roos-class-hierarchy class-filter) hierarchy-name)))

(define (roos-add-doc %class %spod)
  (let ((name (roos-class-name %class)))
    (%roos-add-doc-to-class name %spod)))

(define (roos-prepend-doc %class %spod)
  (let ((name (roos-class-name %class)))
    (%roos-prepend-doc-to-class name %spod)))
  

(provide  def-class
	  def-generic
	  class?
	  object?
	  class=? 
	  class
	  ->
	  ->>
          roos-cleanup
          -<
	  roos-invalid?
          =>
          named-argument
	  roos-add-proxy
	  roos-version
	  roos-id
	  roos-dispatch
	  roos-class-doc
	  roos-class-name
	  roos-add-doc
	  roos-prepend-doc
	  roos-map-classes
	  roos->spod
	  roos-class-change
	  roos-class-hierarchy
	  roos-class-hierarchy->spod
	  roos-classes->spod
	  (all-from "spod-roos.scm")
          )

)