;;; This file has some random utilities dealing with instances.
 
 ;;; Right now, this is a linear search off the class.
 
 (define (lookup-instance alg-def class-def)
   (let ((res (lookup-instance-1 alg-def (class-instances class-def))))
     (if (and (eq? res '#f) (algdata-real-tuple? alg-def))
 	(lookup-possible-tuple-instances alg-def class-def)
 	res)))
 
 (define (lookup-instance-1 alg-def instances)
   (cond ((null? instances)
 	 '#f)
 	((eq? (instance-algdata (car instances)) alg-def)
 	 (if (instance-ok? (car instances))
 	     (car instances)
 	     '#f))
 	(else
 	 (lookup-instance-1 alg-def (cdr instances)))))
 
 (define (lookup-possible-tuple-instances alg-def class-def)
   (cond ((eq? class-def (core-symbol "Eq"))
 	 (get-tuple-eq-instance alg-def))
 	((eq? class-def (core-symbol "Ord"))
 	 (get-tuple-ord-instance alg-def))
 	((eq? class-def (core-symbol "Ix"))
 	 (get-tuple-ix-instance alg-def))
 	((eq? class-def (core-symbol "Text"))
 	 (get-tuple-text-instance alg-def))
 	((eq? class-def (core-symbol "Binary"))
 	 (get-tuple-binary-instance alg-def))
 	(else '#f)))
 
 (define *saved-eq-instances* '())
 (define *saved-ord-instances* '())
 (define *saved-ix-instances* '())
 (define *saved-text-instances* '())
 (define *saved-binary-instances* '())
 
 (define (get-tuple-eq-instance tpl)
   (let ((res (assq tpl *saved-eq-instances*)))
     (if (not (eq? res '#f))
 	(tuple-2-2 res)
 	(let ((inst (make-tuple-instance
 		     tpl (core-symbol "Eq") (core-symbol "tupleEqDict"))))
 	  (push (tuple tpl inst) *saved-eq-instances*)
 	  inst))))
 
 (define (get-tuple-ord-instance tpl)
   (let ((res (assq tpl *saved-ord-instances*)))
     (if (not (eq? res '#f))
 	(tuple-2-2 res)
 	(let ((inst (make-tuple-instance
 		     tpl (core-symbol "Ord") (core-symbol "tupleOrdDict"))))
 	  (push (tuple tpl inst) *saved-ord-instances*)
 	  inst))))
 
 (define (get-tuple-ix-instance tpl)
   (let ((res (assq tpl *saved-ix-instances*)))
     (if (not (eq? res '#f))
 	(tuple-2-2 res)
 	(let ((inst (make-tuple-instance
 		     tpl (core-symbol "Ix") (core-symbol "tupleIxDict"))))
 	  (push (tuple tpl inst) *saved-ix-instances*)
 	  inst))))
 
 (define (get-tuple-text-instance tpl)
   (let ((res (assq tpl *saved-text-instances*)))
     (if (not (eq? res '#f))
 	(tuple-2-2 res)
 	(let ((inst (make-tuple-instance
 		     tpl (core-symbol "Text") (core-symbol "tupleTextDict"))))
 	  (push (tuple tpl inst) *saved-text-instances*)
 	  inst))))
 
 (define (get-tuple-binary-instance tpl)
   (let ((res (assq tpl *saved-binary-instances*)))
     (if (not (eq? res '#f))
 	(tuple-2-2 res)
 	(let ((inst (make-tuple-instance
 		     tpl (core-symbol "Binary")
 		     (core-symbol "tupleBinaryDict"))))
 	  (push (tuple tpl inst) *saved-binary-instances*)
 	  inst))))
 
 (define (make-tuple-instance algdata class dict)
   (let* ((size (tuple-size algdata))
 	 (tyvars (gen-symbols size))
 	 (context (map (lambda (tyvar)
 			  (**context (**class/def class) tyvar))
 			tyvars))
 	 (sig (**tycon/def algdata (map (lambda (x) (**tyvar x)) tyvars)))
 	 (gcontext (gtype-context (ast->gtype context sig))))
     (make instance 
 	  (algdata algdata)
 	  (tyvars tyvars)
 	  (class class)
 	  (context context)
 	  (gcontext gcontext)
 	  (methods '())
 	  (dictionary dict)
 	  (ok? '#t)
 	  (special? '#t))))
 
 ;;; I know these are somewhere else too ...
 
 (define (tuple-size alg)
   (con-arity (car (algdata-constrs alg))))
 
 (define (gen-symbols n)
   (gen-symbols-1 n '(|a| |b| |c| |d| |e| |f| |g| |h| |i| |j| |k| |l| |m|
 		     |n| |o| |p| |q| |r| |s| |t| |u| |v| |w| |x| |y| |z|)))
 
 (define (gen-symbols-1 n vars)
   (if (eqv? n 0)
       '()
       (if (null? vars)
 	  (cons (string->symbol (format '#f "x~A" n))
 		(gen-symbols-1 (1- n) '()))
 	  (cons (car vars) (gen-symbols-1 (1- n) (cdr vars))))))
 
 ;;; This handles the dynamic linking of instances into classes
 
 (define (link-instances modules)
   (dolist (m modules)
     ;; clear out any instances sitting around from old compiles
     (dolist (class (module-class-defs m))
       (setf (class-instances class) '())))
   (dolist (m modules)
     (dolist (inst (module-instance-defs m))
        (link-instance inst)))
   )
 
 (define (link-instance inst)  ; links an instance into the associated class
   (push inst (class-instances (instance-class inst))))
 
 ;;; This creates a new instance object and installs it.
 
 (predefine (make-new-var name))  ; in tdecl/tdecl-utils.scm
 
 (define (new-instance class algdata tyvars)
  (let* ((dict-name
 	 (string-append "dict-"
 			(symbol->string (print-name class)) "-"
 			(symbol->string (print-name algdata))))
 	(inst (make instance (algdata algdata)
 			     (tyvars tyvars)
 		             (class class)
 			     (gcontext '())
 			     (context '())
 			     (dictionary (make-new-var dict-name)))))
    (link-instance inst)
    inst))