git.fiddlerwoaroof.com
printers/print-ntypes.scm
4e987026
 ;;; 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)))))