;;;; fast-generic.scm
;
; By Thant Tessman, ported to CHICKEN by felix


(module fast-generic ((define-generic build-or-clause)
		      generic-error
		      define-type)

(import scheme chicken)
(import-for-syntax matchable srfi-1)
(begin-for-syntax (require-library fast-generic-compile-time))
(import fast-generic-compile-time)
(import-for-syntax fast-generic-compile-time)


(define-syntax (define-type x r c)
  (match x
    ((_ name pred) 
     (register-type name (r pred) 'any))
    ((_ name pred base)
     (register-type name (r pred) base)))
  `(,(r 'void)))

(define-syntax (define-generic x r c)
  (let ((%begin (r 'begin))
	(%define-compiler-syntax (r 'define-compiler-syntax))
	(%let* (r 'let*))
	(%let (r 'let))
	(%if (r 'if))
	(%or (r 'or))
	(%and (r 'and))
	(%begin (r 'begin))
	(%list (r 'list))
	(%set! (r 'set!))
	(%car (r 'car))
	(%cdr (r 'cdr))
	(%map (r 'map))
	(%null? (r 'null?))
	(%lambda (r 'lambda))
	(%cons (r 'cons))
	(%get (r 'get))
	(%cons (r 'cons))
	(%cons* (r 'cons*))
	(%quote (r 'quote))
	(%error (r 'error))
	(%eq? (r 'eq?))
	(%length (r 'length))
	(%gensym (r 'gensym))
	(%build-or-clause (r 'build-or-clause))
	(%generic-error (r 'generic-error))
	(%generic-forms (r 'generic-forms))
	(%define (r 'define)))
    (match x
      ((_ (name types+bindings ...) body ...)
       (let* ((types (map (lambda (a) (if (symbol? a) 'any (car a))) types+bindings))
	      (bindings (map (lambda (a) (if (symbol? a) a (cadr a))) types+bindings))
	      (full-name (generic-build-name name types))
	      (dummy (generic-data-add name full-name types))
	      (params (map (lambda _ (gensym)) bindings))
	      (unset (gensym))
	      (len (length bindings))
	      (fresult (gensym)))
	 `(,%begin
	   (,%define (,full-name ,@bindings) ,@body)
	   (,%define (,name ,@bindings)
	     (,%let* ((,unset (,%cons 'unset '()))
		      (,fresult ,unset))
		    ,(build-or-clause
		      (get name 'generic-trees)
		      bindings
		      bindings
		      fresult
		      r)
		    (,%if (,%eq? ,unset ,fresult)
			  (,%generic-error
			   ',name
			   (,%list ,@bindings)
			   ',(generic-forms name))
			  ,fresult)))
	   (,%define-compiler-syntax 
	    ,name
	    (,%lambda 
	     (x2 r2 c2)
	     (if (,%eq? ,len (,%length (,%cdr x2)))
		 (,%let* ((arg-list (,%cdr x2))
			  (result (,%gensym))
			  (unset (,%gensym))
			  (args (,%map (lambda _ (,%gensym)) arg-list))
			  (method-body
			   (,%build-or-clause
			    (,%get ',name 'generic-trees)
			    args
			    args
			    result
			    r2)))
			 (,%list
			  (r2 'let*)
			  (,%cons (,%list unset (,%list (r2 'cons) 
							(,%list (r2 'quote) 'unset)
							(,%list (r2 'quote) '())))
				  (,%cons (,%list result unset)
					  (,%map ,%list args arg-list)))
			  method-body
			  (,%list (r2 'if) 
				  (,%list (r2 'eq?) result unset)
				  (,%list
				   (r2 'generic-error)
				   (,%list (r2 'quote) ',name)
				   (,%cons (r2 'list) args)
				   (,%list (r2 'quote) ',(generic-forms name)))
				  result)))
		 x2)))))))))

(define (generic-error name args expected)
  (error 
   name
   (sprintf
    "argument mismatch - was given `~s' but expected"
    args)
   expected))

(define (##fast-generic#any? x) #t)	; must be available, even if renamed

)