;; These macros are adapted from the ones in the tinyclos egg.

; From '@' by Dan Muresan
(define-syntax slot@
  (syntax-rules (=)
    ((_ o) o)
    ((_ o slot = v) (slot-set! o 'slot v))
    ((_ o slot . slots) (slot@ (slot-ref o 'slot) . slots))))

(define-syntax define-class
  (syntax-rules ()
    [(_ name () slots)
     (define-class name (<object>) slots) ]
    [(_ name supers slots)
     (define-class name supers slots <class>) ]
    [(_ name () slots meta)
     (define-class name (<object>) slots meta) ]
    [(_ cname (supers ...) (slots ...) meta)
     (define cname (make meta 'name 'cname 'direct-supers (list supers ...) 'direct-slots (list 'slots ...))) ] ) )

(define-syntax define-generic
  (syntax-rules ()
    [(_ n class) (define n (make class 'name 'n))]
    [(_ n) (define n (make-generic 'n))] ) )


(define-syntax (define-method x r c)
  (let ((head (cadr x))
	(body (cddr x))
	(%add-method (r 'add-method))
	(%make-method (r 'make-method))
	(%lambda (r 'lambda))
	(%list (r 'list))
	(%<top> (r '<top>)))
    (##sys#check-syntax 'define-method head '(symbol . _))
    (##sys#check-syntax 'define-method body '#(_ 1))
    (let gather ([args (##sys#slot head 1)]
		 [specs '()]
		 [vars '()] )
      (if (or (not (pair? args))
	      (memq (car args) '(#!optional #!key #!rest)) )
	  (let ([name (##sys#slot head 0)])
	    `(,%add-method ,name
		(,%make-method (,%list ,@(reverse specs))
			      (,%lambda (call-next-method ,@(reverse vars) ,@args) ,@body) ) ) )
	  (let ([arg (##sys#slot args 0)])
	    (gather (##sys#slot args 1)
		    (cons (if (pair? arg) (cadr arg) %<top>) specs)
		    (cons (if (pair? arg) (car arg) arg) vars) ) ) ) ) ) )