;;; These printers deal with ntype structures.

;;; Too much of this file is copied from print-types!

(define-ast-printer ntyvar (object xp)
  (let ((object (prune object)))
    (if (ntyvar? object)
	(begin
	  (write-char #\t xp)
	  (write (tyvar->number object) xp))
	(write object xp))))

;;; Various type special cases have a magic cookie in the def field.

(define-ast-printer ntycon (object xp)
  (let ((tycon (ntycon-tycon object)))
    (if (eq? tycon '#f)
	(write-string "<Bogus tycon>" xp)
	(print-general-tycon tycon (ntycon-args object) object xp))))

(define-ast-printer gtype (object xp)
  (let ((var 0)
	(res '()))
    (dolist (classes (gtype-context object))
       (let ((v (gtyvar->symbol var)))
	 (dolist (class classes)
	    (push (**context (**class/def class) v) res)))
       (incf var))
    (write-contexts (reverse res) xp)
    (write (gtype-type object) xp)))
          
(define-ast-printer gtyvar (object xp)
  (write-string (symbol->string (gtyvar->symbol (gtyvar-varnum object))) xp))

(define (gtyvar->symbol n)
  (cond ((< n 26)
	 (list-ref '(|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|)
		   n))
	(else
	 (string->symbol (format '#f "g~A" (- n 25))))))

(define-ast-printer recursive-type (object xp)
  (write (recursive-type-type object) xp))

(define (tyvar->number tyvar)
  (tyvar->number-1 tyvar (dynamic *printed-tyvars*) 1))

(define (tyvar->number-1 tyvar vars n)
  (cond ((null? vars)
	 (setf (dynamic *printed-tyvars*)
	       (nconc (dynamic *printed-tyvars*) (list tyvar)))
	 n)
	((eq? tyvar (car vars))
	 n)
	(else
	 (tyvar->number-1 tyvar (cdr vars) (1+ n)))))