From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001
From: Yale AI Dept <ai@nebula.cs.yale.edu>
Date: Wed, 14 Jul 1993 13:08:00 -0500
Subject: Import to github.

---
 printers/print-ntypes.scm | 61 +++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 61 insertions(+)
 create mode 100644 printers/print-ntypes.scm

(limited to 'printers/print-ntypes.scm')

diff --git a/printers/print-ntypes.scm b/printers/print-ntypes.scm
new file mode 100644
index 0000000..c018f40
--- /dev/null
+++ b/printers/print-ntypes.scm
@@ -0,0 +1,61 @@
+;;; 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)))))
+
+
-- 
cgit v1.2.3