;;; This file creates type definitions for tuples of arbitrary size.
 
 (define *tuple-definitions* '())
 
 (define (init-tuples)
   (setf *tuple-definitions* '()))
 
 (define (tuple-tycon k)
   (let ((tycon (assq k *tuple-definitions*)))
     (if (eq? tycon '#f)
 	(new-tuple-tycon k)
 	(tuple-2-2 tycon))))
 
 (define (tuple-constructor k)
   (car (algdata-constrs (tuple-tycon k))))
 
 (define (is-tuple-constructor? x)
   (and (con? x) (is-tuple-tycon? (con-alg x))))
 
 (define (is-tuple-tycon? x)
   (and (algdata? x) (algdata-real-tuple? x)))
 
 (define (tuple-constructor-arity x)
   (con-arity x))
 
 (predefine (ast->gtype c t))          ; in util/type-utils.scm
 (predefine (**arrow-type/l args))     ; in util/constructors.scm
 (predefine (**tyvar x))               ; in util/constructors.scm
 
 (define (new-tuple-tycon k)
   (cond ((eqv? k 0)
 	 (core-symbol "UnitType"))
 	(else
 	 (let* ((name (string->symbol (format '#f "Tuple~A" k)))
 		(cname (string->symbol (format '#f ";MkTuple~A" k)))
 		(dummy-vars (gen-dummy-names k))
 		(algdata (make algdata
 			       (name name)
 			       (module '*core*)
 			       (unit '*core*)
 			       (exported? '#t)
 			       (arity k)
 			       (n-constr 1)
 			       (context '())
 			       (tyvars dummy-vars)
 			       (classes '())  ;; filled in later
 			       (enum? '#f)
 			       (tuple? '#t)
 			       (real-tuple? '#t)
 			       (deriving '())))
 		(constr (make con
 			      (name cname)
 			      (module '*core*)
 			      (unit '*core*)
 			      (exported? '#t)
 			      (arity k)
 			      (types (map (function **tyvar) dummy-vars))
 			      (tag 0)
 			      (alg algdata)
 			      (slot-strict? '())
 			      (infix? '#f)))
 		(tyvars (map (function **tyvar) dummy-vars))
 		(tuple-type (**tycon/def algdata tyvars)))
 	   (dotimes (i k)
 	      (push '#f (con-slot-strict? constr)))
 	   (setf (algdata-signature algdata)
 		 (ast->gtype '() tuple-type))
 	   (setf (con-signature constr)
 		 (ast->gtype '() (**arrow-type/l
 				  (append tyvars (list tuple-type)))))
 	   (setf (algdata-constrs algdata)
 		 (list constr))
 	   (push (tuple k algdata) *tuple-definitions*)
 	   algdata))))
 
 (define (gen-dummy-names n)
   (gen-dummy-names-1 n '()))
 
 (define (gen-dummy-names-1 n l)
   (if (eqv? n 0)
       l
       (gen-dummy-names-1 (1- n)
 			 (cons (string->symbol (format '#f "a~A" n)) l))))