;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; $Id: roos.scm,v 1.38.2.7 2006/01/02 21:03:31 HansOesterholt Exp $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; $Log: roos.scm,v $
; 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 mzscheme
	(require "c-roos.scm")


(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.38.2.7 $;
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;=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)))))
;=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-is-class? class)
  (let ((c (%roos-assoc class %roos-class-definitions)))
    (eq? c class)))

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

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

(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))))
    

;=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
  (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-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
  (syntax-rules ()
    ((%roos-class
      ((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
     (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
;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;=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
  (syntax-rules ()
    ((_
      (this %this ...)
      (supers super1 ...)
      (private private1 ...)
      (public public1 ...)
      (constructor c1 ...))
     (def-class
      (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 ...))
     (%roos-class
      ((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.00"))
;=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))))))

(provide  def-class
	  def-generic
	  class?
	  object?
	  class=? 
	  class
	  ->
	  ->>
          roos-cleanup
          -<
	  roos-invalid?
          =>
          named-argument
	  roos-add-proxy
	  roos-version
	  roos-id
	  roos-dispatch
; 	  add-member
          ))