Import to github.

8 files changed, 1238 insertions, 0 deletions

diff --git a/printers/README b/printers/README
new file mode 100644
index 0000000..36530ed
--- /dev/null
+++ b/printers/README
@@ -0,0 +1,19 @@
+This directory contains print routines for the structures defined in
+the ast/ directory.
+
+The global *print-structure* controls printing of objects in the
+structure system.  Values are:
+  haskell  -- Prints haskell format expressions from ast
+  struct   -- Prints the raw structs (with circularity check)
+  top      -- Prints top level only of the struct
+
+The file defs.scm has the basic hooks to the printer mechanism.  The
+idea is that when *print-structure* is 'haskell, the print function stored
+in the type descriptor will get used.  If there isn't a print function,
+or if *print-structure* is false, then the thing will print out in
+some generic way that's good for debugging purposes.
+
+The macro define-printer is used to associate a print function with a
+structure type.  Since these can be defined on the fly, the print
+dispatching routine has to look up the inheritance chain of type
+descriptors looking for the first inherited type that has a printer.
diff --git a/printers/print-exps.scm b/printers/print-exps.scm
new file mode 100644
index 0000000..2a9d89b
--- /dev/null
+++ b/printers/print-exps.scm
@@ -0,0 +1,410 @@
+;;; print-exps.scm -- print expression AST structures
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  10 Jan 1992
+;;;
+;;; This file corresponds to ast/exp-structs.scm.
+;;;
+
+(define-ast-printer lambda (object xp)
+  (with-ast-block (xp)
+    (write-string "\\ " xp)
+    (write-delimited-list
+      (lambda-pats object) xp (function write-apat) "" "" "")
+    (write-string " ->" xp)
+    (write-whitespace xp)
+    (write (lambda-body object) xp)))
+
+(define-ast-printer let (object xp)
+  (write-lets-body "let " (let-decls object) (let-body object) xp))
+
+(define (write-lets-body let-name decls body xp)
+  (pprint-logical-block (xp '() "" "")  ; no extra indentation
+    (write-string let-name xp)
+    (write-layout-rule (remove-recursive-grouping decls) xp (function write))
+    (write-whitespace xp)
+    (write-string "in " xp)
+    (write body xp)))
+
+(define-ast-printer if (object xp)
+  (with-ast-block (xp)
+    (write-string "if " xp)
+    (write (if-test-exp object) xp)
+    (write-whitespace xp)
+    (with-ast-block (xp)
+      (write-string "then" xp)
+      (write-whitespace xp)
+      (write (if-then-exp object) xp))
+    (write-whitespace xp)
+    (with-ast-block (xp)
+      (write-string "else" xp)
+      (write-whitespace xp)
+      (write (if-else-exp object) xp))))
+
+(define-ast-printer case (object xp)
+  (with-ast-block (xp)
+    (write-string "case " xp)
+    (write (case-exp object) xp)
+    (write-string " of" xp)
+    (write-whitespace xp)
+    (write-layout-rule (case-alts object) xp (function write))))
+
+(define-ast-printer alt (object xp)
+  (with-ast-block (xp)
+    (write (alt-pat object) xp)
+    (dolist (r (alt-rhs-list object))
+      (write-whitespace xp)
+      (unless (is-type? 'omitted-guard (guarded-rhs-guard r))
+	(write-string "| " xp)
+	(write (guarded-rhs-guard r) xp))
+      (write-string " -> " xp)
+      (write (guarded-rhs-rhs r) xp))
+    (write-wheredecls (alt-where-decls object) xp)))
+
+(define-ast-printer exp-sign (object xp)
+  (with-ast-block (xp)
+    (write (exp-sign-exp object) xp)
+    (write-string " ::" xp)
+    (write-whitespace xp)
+    (write (exp-sign-signature object) xp)))
+
+;;; Have to look for application of special-case constructors before
+;;; doing the normal prefix/infix cases.
+
+(define-ast-printer app (object xp)
+  (let* ((fn          (app-fn object))
+	 (arg         (app-arg object)))
+    (multiple-value-bind (con args) (extract-constructor fn (list arg))
+      (cond ;; ((eq? con (core-symbol "UnitConstructor"))
+	    ;;  *** Does this ever happen?
+	    ;;  (write-string "()" xp))
+	    ((and con (is-tuple-constructor? con))
+	     (write-commaized-list args xp))
+	    (else
+	     (multiple-value-bind (fixity op arg1) (extract-infix-operator fn)
+	       (if fixity
+		   (write-infix-application fixity op arg1 arg xp)
+		   (write-prefix-application fn arg xp))))
+	    ))))
+
+
+(define (write-infix-application fixity op arg1 arg2 xp)
+  (let ((precedence      (fixity-precedence fixity))
+	(associativity   (fixity-associativity fixity)))
+    (with-ast-block (xp)
+      (write-exp-with-precedence
+        arg1 (1+ precedence) (if (eq? associativity 'l) 'l '#f) xp)
+      (write-whitespace xp)
+      (write op xp)
+      (write-whitespace xp)
+      (write-exp-with-precedence
+        arg2 (1+ precedence) (if (eq? associativity 'r) 'r '#f) xp))))
+
+(define (write-prefix-application fn arg xp)      
+  (with-ast-block (xp)
+    (write-exp-with-precedence fn 10 '#f xp)
+    (write-whitespace xp)
+    (write-aexp arg xp)))
+
+
+;;; Write an expression with at least the given precedence.  If the
+;;; actual precedence is lower, put parens around it.
+
+(define *print-exp-parens* '#f)
+
+(define (write-exp-with-precedence exp precedence associativity xp)
+  (if *print-exp-parens*
+      (write-aexp exp xp)
+      (if (< (precedence-of-exp exp associativity) precedence)
+	  (begin
+	    (write-char #\( xp)
+	    (write exp xp)
+	    (write-char #\) xp))
+	  (write exp xp))))
+
+
+;;; Similar to the above: write an aexp.
+
+(define *print-original-code* '#t)
+
+(define (write-aexp object xp)
+  (if (is-type? 'save-old-exp object)
+      (write-aexp (if *print-original-code*
+		      (save-old-exp-old-exp object)
+		      (save-old-exp-new-exp object))
+		  xp)
+      (if (or (is-type? 'aexp object)
+	      (pp-exp-list-section? object)
+	      (is-type? 'negate object))
+	  (write object xp)
+	  (begin
+	    (write-char #\( xp)
+	    (write object xp)
+	    (write-char #\) xp)))))
+
+
+;;; The infix? slot on var-ref and con-ref structs refers to whether
+;;; the thing appears as an infix operator or not, not whether the name
+;;; has operator or identifier syntax.
+
+(define-ast-printer var-ref (object xp)
+  (let ((name  (var-ref-name object)))
+    (if (var-ref-infix? object)
+	(write-varop name xp)
+	(write-varid name xp))))
+
+(define-ast-printer con-ref (object xp)
+  (if (eq? (con-ref-con object) (core-symbol "UnitConstructor"))
+      (write-string "()" xp)
+      (let ((name  (con-ref-name object)))
+	(if (con-ref-infix? object)
+	    (write-conop name xp)
+	    (write-conid name xp)))))
+
+
+(define-ast-printer integer-const (object xp)
+  (write (integer-const-value object) xp))
+
+(define-ast-printer float-const (object xp)
+  (let* ((numerator   (float-const-numerator object))
+	 (denominator (float-const-denominator object))
+	 (exponent    (float-const-exponent object))
+	 (whole       (quotient numerator denominator))
+	 (fraction    (remainder numerator denominator)))
+    (write whole xp)
+    (write-char #\. xp)
+    (write-precision-integer fraction denominator xp)
+    (unless (zero? exponent)
+      (write-char #\E xp)
+      (write exponent xp))))
+
+(define (write-precision-integer fraction denominator xp)
+  (cond ((eqv? denominator 1)
+	 ; no fraction
+	 )
+	((eqv? denominator 10)
+	 (write-digit fraction xp))
+	(else
+	 (write-digit (quotient fraction 10) xp)
+	 (write-precision-integer (remainder fraction 10)
+				  (quotient denominator 10)
+				  xp))
+	))
+
+(define (write-digit n xp)
+  (write-char (string-ref "0123456789" n) xp))
+
+
+;;; Character and string printers need to handle weird escapes.
+;;; Fortunately we can just choose one canonical style for printing
+;;; unprintable characters.
+
+(define-ast-printer char-const (object xp)
+  (write-char #\' xp)
+  (write-char-literal (char-const-value object) xp #\')
+  (write-char #\' xp))
+
+(define-ast-printer string-const (object xp)
+  (write-char #\" xp)
+  (let ((s  (string-const-value object)))
+    (dotimes (i (string-length s))
+      (write-char-literal (string-ref s i) xp #\")))
+  (write-char #\" xp))
+
+(define (write-char-literal c xp special)
+  (cond ((eqv? c special)
+	 (write-char #\\ xp)
+	 (write c xp))
+	((eqv? c #\newline)
+	 (write-char #\\ xp)
+	 (write-char #\n xp))
+	(else
+	 (let ((code  (char->integer c)))
+	   (if (and (>= code 32) (< code 128))
+	       ;; printing ascii characters
+	       (write-char c xp)
+	       ;; "control" characters print in \ddd notation
+	       (begin
+		 (write-char #\\ xp)
+		 (write code xp)))))
+	))
+
+(define-ast-printer list-exp (object xp)
+  (write-delimited-list
+    (list-exp-exps object) xp (function write) "," "[" "]"))
+
+(define-ast-printer sequence (object xp)
+  (with-ast-block (xp)
+    (write-string "[" xp)
+    (write (sequence-from object) xp)
+    (write-string "..]" xp)))
+
+(define-ast-printer sequence-to (object xp)
+  (with-ast-block (xp)
+    (write-string "[" xp)
+    (write (sequence-to-from object) xp)
+    (write-string " .." xp)
+    (write-whitespace xp)
+    (write (sequence-to-to object) xp)
+    (write-string "]" xp)))
+
+(define-ast-printer sequence-then (object xp)
+  (with-ast-block (xp)
+    (write-string "[" xp)			
+    (write (sequence-then-from object) xp)
+    (write-string "," xp)
+    (write-whitespace xp)
+    (write (sequence-then-then object) xp)
+    (write-string "..]" xp)))
+
+(define-ast-printer sequence-then-to (object xp)
+  (with-ast-block (xp)
+    (write-string "[" xp)
+    (write (sequence-then-to-from object) xp)
+    (write-string "," xp)
+    (write-whitespace xp)
+    (write (sequence-then-to-then object) xp)
+    (write-string " .." xp)
+    (write-whitespace xp)
+    (write (sequence-then-to-to object) xp)
+    (write-string "]" xp)))
+
+(define-ast-printer list-comp (object xp)
+  (with-ast-block (xp)
+    (write-string "[" xp)
+    (write (list-comp-exp object) xp)
+    (write-string " |" xp)
+    (write-whitespace xp)
+    (write-delimited-list
+      (list-comp-quals object) xp (function write) "," "" "")
+    (write-string "]" xp)))
+
+
+(define-ast-printer section-l (object xp)
+  (let* ((exp           (section-l-exp object))
+	 (op            (section-l-op object))
+	 (fixity        (operator-fixity op))
+	 (precedence    (fixity-precedence fixity)))
+    (with-ast-block (xp)
+      (write-string "(" xp)
+      (write op xp)
+      (write-whitespace xp)
+      (write-exp-with-precedence exp (1+ precedence) '#f xp)
+      (write-string ")" xp))))
+
+(define-ast-printer section-r (object xp)
+  (let* ((exp           (section-r-exp object))
+	 (op            (section-r-op object))
+	 (fixity        (operator-fixity op))
+	 (precedence    (fixity-precedence fixity)))
+    (with-ast-block (xp)
+      (write-string "(" xp)
+      (write-exp-with-precedence exp (1+ precedence) '#f xp)
+      (write-whitespace xp)
+      (write op xp)
+      (write-string ")" xp))))
+
+(define-ast-printer qual-generator (object xp)
+  (with-ast-block (xp)
+    (write (qual-generator-pat object) xp)
+    (write-string " <-" xp)
+    (write-whitespace xp)
+    (write (qual-generator-exp object) xp)))
+
+(define-ast-printer qual-filter (object xp)
+  (write (qual-filter-exp object) xp))
+
+
+;;; A pp-exp-list with an op as the first or last element is really
+;;; a section.  These always get parens and are treated like aexps.
+;;; Other pp-exp-lists are treated as exps with precedence 0.
+;;; Bleah...  Seems like the parser ought to recognize this up front....
+;;;                                                     Yeah but I'm lazy ...
+
+(define-ast-printer pp-exp-list (object xp)
+  (let ((section?  (pp-exp-list-section? object)))
+    (if section? (write-char #\( xp))
+    (write-delimited-list
+      (pp-exp-list-exps object) xp (function write-aexp) "" "" "")
+    (if section? (write-char #\) xp))))
+
+(define-ast-printer negate (object xp)
+  (declare (ignore object))
+  (write-string "-" xp))
+
+(define-ast-printer def (object xp)
+  (write-string (symbol->string (def-name object)) xp))
+
+(define-ast-printer con (object xp)
+  (write-string (remove-con-prefix (symbol->string (def-name object))) xp))
+
+(define-ast-printer con-number (object xp)
+  (with-ast-block (xp)
+    (write-string "con-number/" xp)
+    (write (con-number-type object) xp)
+    (write-whitespace xp)
+    (write-aexp (con-number-value object) xp)))
+
+(define-ast-printer sel (object xp)
+  (with-ast-block (xp)
+    (write-string "sel/" xp)
+    (write (sel-constructor object) xp)
+    (write-whitespace xp)
+    (write (sel-slot object) xp)
+    (write-whitespace xp)
+    (write-aexp (sel-value object) xp)))
+
+(define-ast-printer is-constructor (object xp)
+(with-ast-block (xp)
+    (write-string "is-constructor/" xp)
+    (write (is-constructor-constructor object) xp)
+    (write-whitespace xp)
+    (write-aexp (is-constructor-value object) xp)))
+  
+(define-ast-printer void (object xp)
+  (declare (ignore object))
+  (write-string "Void" xp))
+
+;;; Special cfn constructs
+
+(define-ast-printer case-block (object xp)
+  (with-ast-block (xp)
+    (write-string "case-block " xp)
+    (write (case-block-block-name object) xp)
+    (write-whitespace xp)
+    (write-layout-rule (case-block-exps object) xp (function write))))
+
+(define-ast-printer return-from (object xp)
+  (with-ast-block (xp)
+    (write-string "return-from " xp)
+    (write (return-from-block-name object) xp)
+    (write-whitespace xp)
+    (write (return-from-exp object) xp)))
+
+(define-ast-printer and-exp (object xp)
+  (with-ast-block (xp)
+    (write-string "and " xp)
+    (write-layout-rule (and-exp-exps object) xp (function write))))
+
+;;; Expression types used by the type checker.
+
+(define-ast-printer dict-placeholder (object xp)
+  (cond ((not (eq? (dict-placeholder-exp object) '#f))
+	 (write (dict-placeholder-exp object) xp))
+	(else
+	 (write-string "%" xp)
+	 (write-string (symbol->string
+			(def-name (dict-placeholder-class object))) xp))))
+
+(define-ast-printer recursive-placeholder (object xp)
+  (cond ((not (eq? (recursive-placeholder-exp object) '#f))
+	 (write (recursive-placeholder-exp object) xp))
+	(else
+	 (write-varid (def-name (recursive-placeholder-var object)) xp))))
+
+;;; This should probably have a flag to allow the dictionary converted code
+;;; to be printed during debugging.
+
+(define-ast-printer save-old-exp (object xp)
+  (write (save-old-exp-old-exp object) xp))
+
diff --git a/printers/print-modules.scm b/printers/print-modules.scm
new file mode 100644
index 0000000..2372714
--- /dev/null
+++ b/printers/print-modules.scm
@@ -0,0 +1,125 @@
+;;; print-modules.scm -- print routines for module-related AST structures
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  6 Jan 1992
+;;;
+;;;
+;;; This file corresponds to the file ast/modules.scm.
+
+;;; Note: by default, only the module name is printed.  To print the
+;;; full module, the function print-full-module must be called.
+
+(define *print-abbreviated-modules* '#t)
+
+(define-ast-printer module (object xp)
+ (if *print-abbreviated-modules*
+     (begin
+       (write-string "Module " xp)
+       (write-string (symbol->string (module-name object)) xp))
+     (do-print-full-module object xp)))
+
+(define (print-full-module object . maybe-stream)
+  (let ((stream  (if (not (null? maybe-stream))
+		     (car maybe-stream)
+		     (current-output-port))))
+    (dynamic-let ((*print-abbreviated-modules* '#f))
+       (pprint object stream))))
+
+(define (do-print-full-module object xp)
+ (dynamic-let ((*print-abbreviated-modules* '#t))
+  (let ((modid    (module-name object))
+	(exports  (module-exports object))
+	(body     (append (module-imports object)
+			  (module-fixities object)
+			  (module-synonyms object)
+			  (module-algdatas object)
+			  (module-classes object)
+			  (module-instances object)
+			  (if (or (not (module-default object))
+				  (eq? (module-default object)
+				       *standard-module-default*))
+			      '()
+			      (list (module-default object)))
+			  (module-decls object))))
+    (write-string "module " xp)
+    (write-modid modid xp)
+    (when (not (null? exports))
+      (write-whitespace xp)
+      (write-commaized-list exports xp))
+    (write-wheredecls body xp))))
+
+(define-ast-printer import-decl (object xp)
+  (let ((modid     (import-decl-module-name object))
+	(mode      (import-decl-mode object))
+	(specs     (import-decl-specs object))
+	(renamings (import-decl-renamings object)))
+    (with-ast-block (xp)
+      (write-string "import " xp)
+      (write-modid modid xp)
+      (if (eq? mode 'all)
+	  (when (not (null? specs))
+	    (write-whitespace xp)
+	    (write-string "hiding " xp)
+	    (write-commaized-list specs xp))
+	  (begin
+	    (write-whitespace xp)
+	    (write-commaized-list specs xp)))
+      (when (not (null? renamings))
+	(write-whitespace xp)
+	(write-string "renaming " xp)
+	(write-commaized-list renamings xp))
+      )))
+
+(define-ast-printer entity-module (object xp)
+  (write-modid (entity-name object) xp)
+  (write-string ".." xp))
+
+(define-ast-printer entity-var (object xp)
+  (write-varid (entity-name object) xp))
+
+(define-ast-printer entity-con (object xp)
+  (write-tyconid (entity-name object) xp))
+
+(define-ast-printer entity-abbreviated (object xp)
+  (write-tyconid (entity-name object) xp)
+  (write-string "(..)" xp))
+
+(define-ast-printer entity-class (object xp)
+  (with-ast-block (xp)
+    (write-tyclsid (entity-name object) xp)
+    (write-whitespace xp)
+    (write-delimited-list (entity-class-methods object) xp
+			  (function write-varid) "," "(" ")")))
+
+(define-ast-printer entity-datatype (object xp)
+  (with-ast-block (xp)
+    (write-tyconid (entity-name object) xp)
+    (write-whitespace xp)
+    (write-delimited-list (entity-datatype-constructors object) xp
+			  (function write-conid) "," "(" ")")))
+
+
+(define-ast-printer renaming (object xp)
+  (with-ast-block (xp)
+    (write-varid-conid (renaming-from object) xp)
+    (write-string " to" xp)
+    (write-whitespace xp)
+    (write-varid-conid (renaming-to object) xp)))
+
+;;; *** Should it omit precedence if it's 9?
+
+(define-ast-printer fixity-decl (object xp)
+  (let* ((fixity         (fixity-decl-fixity object))
+	 (associativity  (fixity-associativity fixity))
+	 (precedence     (fixity-precedence fixity))
+	 (ops            (fixity-decl-names object)))
+    (with-ast-block (xp)
+      (cond ((eq? associativity 'l)
+	     (write-string "infixl " xp))
+	    ((eq? associativity 'r)
+	     (write-string "infixr " xp))
+	    ((eq? associativity 'n)
+	     (write-string "infix " xp)))
+      (write precedence xp)
+      (write-whitespace xp)
+      (write-delimited-list ops xp (function write-varop-conop) "," "" ""))))
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)))))
+
+
diff --git a/printers/print-types.scm b/printers/print-types.scm
new file mode 100644
index 0000000..53d3bee
--- /dev/null
+++ b/printers/print-types.scm
@@ -0,0 +1,201 @@
+;;; print-types.scm -- print type-related AST structures
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  15 Jan 1991
+;;;
+;;; This file corresponds to the stuff in ast/type-structs.scm
+;;;
+
+(define-ast-printer tyvar (object xp)
+  (write-avarid (tyvar-name object) xp))
+
+
+;;; Various type special cases have a magic cookie in the def field.
+
+(define-ast-printer tycon (object xp)
+  (print-general-tycon (tycon-def object) (tycon-args object) object xp))
+
+(define (print-general-tycon def args object xp)
+    (cond ((eq? def (core-symbol "Arrow"))
+	   (write-arrow-tycon args xp))
+	  ((eq? def (core-symbol "UnitType"))
+	   (write-unit-tycon xp))
+	  ((eq? def (core-symbol "List"))
+	   (write-list-tycon args xp))
+	  ((is-tuple-tycon? def)
+	   (write-tuple-tycon args xp))
+	  (else
+	   (write-ordinary-tycon def args object xp))))
+
+(define (write-arrow-tycon args xp)
+  (with-ast-block (xp)
+    (write-btype (car args) xp)
+    (write-string " ->" xp)
+    (write-whitespace xp)
+    (write (cadr args) xp)))
+
+(define (write-unit-tycon xp)
+  (write-string "()" xp))
+
+(define (write-list-tycon args xp)
+  (with-ast-block (xp)
+    (write-char #\[ xp)
+    (write (car args) xp)
+    (write-char #\] xp)))
+
+(define (write-tuple-tycon args xp)
+  (write-commaized-list args xp))
+
+(define (write-ordinary-tycon def args object xp)
+  (with-ast-block (xp)
+    (if (tycon? object)
+	(write-tyconid (tycon-name object) xp)
+	(write-tyconid (def-name def) xp))
+    (when (not (null? args))
+      (write-whitespace xp)
+      (write-delimited-list
+        args xp (function write-atype) "" "" ""))))
+
+
+;;; All of the special cases above except "Arrow" are atypes, as is
+;;; a tyvar or a tycon with no arguments.
+
+(define (write-atype object xp)
+ (let ((object (maybe-prune object)))
+  (if (or (tyvar? object)
+	  (gtyvar? object)
+	  (ntyvar? object)
+	  (is-some-tycon? object
+	     (lambda (def)
+	       (or (eq? def (core-symbol "UnitType"))
+		   (eq? def (core-symbol "List"))
+		   (is-tuple-tycon? def)))))
+      (write object xp)
+      (begin
+        (write-char #\( xp)
+	(write object xp)
+	(write-char #\) xp)))))
+
+
+;;; A btype is any type except the arrow tycon.
+
+(define (write-btype object xp)
+ (let ((object (maybe-prune object)))
+  (if (or (and (tycon? object)
+	       (eq? (tycon-def object) (core-symbol "Arrow")))
+	  (and (ntycon? object)
+	       (eq? (ntycon-tycon object) (core-symbol "Arrow"))))
+      (begin
+        (write-char #\( xp)
+	(write object xp)
+	(write-char #\) xp))
+      (write object xp))))
+      
+(define (maybe-prune object)
+  (if (ntyvar? object)
+      (prune object)
+      object))
+
+(define (is-some-tycon? object fn)
+  (let ((object (maybe-prune object)))
+    (or (and (tycon? object)
+	     (or (null? (tycon-args object))
+		 (funcall fn (tycon-def object))))
+	(and (ntycon? object)
+	     (or (null? (ntycon-args object))
+		 (funcall fn (ntycon-tycon object)))))))
+
+(define-ast-printer context (object xp)
+  (with-ast-block (xp)
+    (write (context-class object) xp)
+    (write-whitespace xp)
+    (write-avarid (context-tyvar object) xp)))
+
+(define-ast-printer signature (object xp)
+  (write-contexts (signature-context object) xp)
+  (write (signature-type object) xp))
+
+(define (write-contexts contexts xp)
+  (when (not (null? contexts))
+    (if (null? (cdr contexts))
+	(write (car contexts) xp)
+	(write-commaized-list contexts xp))
+    (write-string " =>" xp)
+    (write-whitespace xp)))
+
+(define-ast-printer synonym-decl (object xp)
+  (with-ast-block (xp)
+    (write-string "type " xp)
+    (write (synonym-decl-simple object) xp)
+    (write-string " =" xp)
+    (write-whitespace xp)
+    (write (synonym-decl-body object) xp)))
+
+(define-ast-printer data-decl (object xp)
+  (with-ast-block (xp)
+    (write-string "data " xp)
+    (write-contexts (data-decl-context object) xp)
+    (write (data-decl-simple object) xp)
+    (write-whitespace xp)
+    (write-char #\= xp)
+    (write-whitespace xp)
+    (write-delimited-list
+      (data-decl-constrs object) xp (function write) " |" "" "")
+    (write-whitespace xp)
+    (let ((deriving  (data-decl-deriving object)))
+      (when (not (null? deriving))
+	(write-string "deriving " xp)
+	(if (null? (cdr deriving))
+	    (write (car deriving) xp)
+	    (write-commaized-list deriving xp))))))
+
+(define-ast-printer constr (object xp)
+  (if (con-ref-infix? (constr-constructor object))
+      (with-ast-block (xp)
+        (write-btype (car (constr-types object)) xp)
+	(write-whitespace xp)
+	(write (constr-constructor object) xp)
+	(write-whitespace xp)
+	(write-btype (cadr (constr-types object)) xp))
+      (with-ast-block (xp)
+	(write (constr-constructor object) xp)
+	(when (not (null? (constr-types object)))
+	  (write-whitespace xp)
+	  (write-delimited-list
+	   (constr-types object) xp (function write-atype) "" "" "")))))
+
+
+(define-ast-printer class-decl (object xp)
+  (with-ast-block (xp)
+    (write-string "class " xp)
+    (write-contexts (class-decl-super-classes object) xp)
+    (write (class-decl-class object) xp)
+    (write-whitespace xp)
+    (write-avarid (class-decl-class-var object) xp)
+    (write-wheredecls (class-decl-decls object) xp)))
+
+(define-ast-printer instance-decl (object xp)
+  (with-ast-block (xp)
+    (write-string "instance " xp)
+    (write-contexts (instance-decl-context object) xp)
+    (write (instance-decl-class object) xp)
+    (write-whitespace xp)
+    (write-atype (instance-decl-simple object) xp)
+    (write-wheredecls (instance-decl-decls object) xp)))
+
+
+;;; Don't print out default decl if the value is the default.
+
+(define-ast-printer default-decl (object xp)
+  (with-ast-block (xp)
+    (write-string "default " xp)
+    (let ((types  (default-decl-types object)))
+      (if (null? (cdr types))
+	  (write (car types) xp)
+	  (write-commaized-list types xp)))))
+
+(define-ast-printer class-ref (object xp)
+  (write-tyclsid (class-ref-name object) xp))
+        
+  
+  
diff --git a/printers/print-valdefs.scm b/printers/print-valdefs.scm
new file mode 100644
index 0000000..908adea
--- /dev/null
+++ b/printers/print-valdefs.scm
@@ -0,0 +1,180 @@
+;;; print-valdefs.scm -- print AST structures for local declarations
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  14 Jan 1992
+;;;
+;;; This file corresponds to ast/valdef-structs.scm.
+;;;
+;;;
+
+
+
+(define-ast-printer signdecl (object xp)
+  (with-ast-block (xp)
+    (write-delimited-list (signdecl-vars object) xp (function write) "," "" "")
+    (write-string " ::" xp)
+    (write-whitespace xp)
+    (write (signdecl-signature object) xp)))
+
+
+;;; This interacts with the layout rule stuff.  See util.scm.
+
+(define-ast-printer valdef (object xp)
+  (let ((lhs         (valdef-lhs object))
+	(definitions (valdef-definitions object)))
+    (write-definition lhs (car definitions) xp)
+    (dolist (d (cdr definitions))
+      (if (dynamic *print-pretty*)
+	  (pprint-newline 'mandatory xp)
+	  (write-string "; " xp))
+      (write-definition lhs d xp))))
+
+
+(define (write-definition lhs d xp)
+  (with-ast-block (xp)
+    (let ((args        (single-fun-def-args d))
+	  (rhs-list    (single-fun-def-rhs-list d))
+	  (where-decls (single-fun-def-where-decls d))
+	  (infix?      (single-fun-def-infix? d)))
+      (write-lhs lhs args infix? xp)
+      (write-rhs rhs-list xp)
+      (write-wheredecls where-decls xp)
+      )))
+				
+(define (write-lhs lhs args infix? xp)       
+  (cond ((null? args)
+	 ;; pattern definition
+	 (write-apat lhs xp)
+	 )
+        ;; If there are args, the lhs is always a var-pat pointing to a 
+        ;; var-ref. The infix? slot from the single-fun-def must override
+	;; the slot on the var-ref, since there can be a mixture of
+	;; infix and prefix definitions for the same lhs.
+	(infix?
+	 ;; operator definition
+	 (when (not (null? (cddr args)))
+	   (write-char #\( xp))
+	 (write-apat (car args) xp)
+	 (write-whitespace xp)
+	 (write-varop (var-ref-name (var-pat-var lhs)) xp)
+	 (write-whitespace xp)
+	 (write-apat (cadr args) xp)
+	 (when (not (null? (cddr args)))
+	   (write-char #\) xp)
+	   (write-whitespace xp)
+	   (write-delimited-list (cddr args) xp (function write-apat)
+				 "" "" "")))
+	(else
+	 ;; normal prefix function definition
+	 (write-varid (var-ref-name (var-pat-var lhs)) xp)
+	 (write-whitespace xp)
+	 (write-delimited-list args xp (function write-apat) "" "" ""))
+	))
+
+(define (write-rhs rhs-list xp)
+  (let ((guard   (guarded-rhs-guard (car rhs-list)))
+	(rhs     (guarded-rhs-rhs   (car rhs-list))))
+    (when (not (is-type? 'omitted-guard guard))
+      (write-string " | " xp)
+      (write guard xp))
+    (write-string " =" xp)
+    (write-whitespace xp)
+    (write rhs xp)
+    (when (not (null? (cdr rhs-list)))
+      (write-newline xp)
+      (write-rhs (cdr rhs-list) xp))))
+
+
+;;; Pattern printers
+
+
+;;; As per jcp suggestion, don't put whitespace after @; line break comes
+;;; before, not after (as is the case for other infix-style punctuation).
+    
+(define-ast-printer as-pat (object xp)
+  (with-ast-block (xp)
+    (write (as-pat-var object) xp)
+    (write-whitespace xp)
+    (write-string "@" xp)
+    (write-apat (as-pat-pattern object) xp)))
+
+(define (write-apat pat xp)
+  (if (or (is-type? 'apat pat)
+	  (is-type? 'pp-pat-plus pat)  ; hack per jcp
+	  (and (is-type? 'pcon pat)
+	       (or (null? (pcon-pats pat))
+		   (eq? (pcon-con pat) (core-symbol "UnitConstructor"))
+		   (is-tuple-constructor? (pcon-con pat)))))
+      (write pat xp)
+      (begin
+        (write-char #\( xp)
+        (write pat xp)
+        (write-char #\) xp))))
+
+(define-ast-printer irr-pat (object xp)
+  (write-string "~" xp)
+  (write-apat (irr-pat-pattern object) xp))
+
+(define-ast-printer var-pat (object xp)
+  (write (var-pat-var object) xp))
+
+(define-ast-printer wildcard-pat (object xp)
+  (declare (ignore object))
+  (write-char #\_ xp))
+
+(define-ast-printer const-pat (object xp)
+  (write (const-pat-value object) xp))
+
+(define-ast-printer plus-pat (object xp)
+  (write (plus-pat-pattern object) xp)
+  (write-string " + " xp)
+  (write (plus-pat-k object) xp))
+
+
+
+(define-ast-printer pcon (object xp)
+  (let ((name    (pcon-name object))
+	(pats    (pcon-pats object))
+	(infix?  (pcon-infix? object))
+	(def     (pcon-con object)))
+    (cond ((eq? def (core-symbol "UnitConstructor"))
+	   (write-string "()" xp))
+	  ((is-tuple-constructor? def)
+	   (write-commaized-list pats xp))
+          ((null? pats)
+	   (if infix?
+	       ;; infix pcon with no arguments can happen inside pp-pat-list
+	       ;; before precedence parsing happens.
+	       (write-conop name xp)
+	       (write-conid name xp)))
+	  (infix?
+	   ;; This could be smarter about dealing with precedence of patterns.
+	   (with-ast-block (xp)
+	     (write-apat (car pats) xp)
+	     (write-whitespace xp)
+	     (write-conop name xp)
+	     (write-whitespace xp)
+	     (write-apat (cadr pats) xp)))
+	  (else
+	   (with-ast-block (xp)
+	     (write-conid name xp)
+	     (write-whitespace xp)
+	     (write-delimited-list pats xp (function write-apat) "" "" "")))
+	  )))
+
+(define-ast-printer list-pat (object xp)
+  (write-delimited-list
+    (list-pat-pats object) xp (function write) "," "[" "]"))
+
+(define-ast-printer pp-pat-list (object xp)
+  (write-delimited-list (pp-pat-list-pats object) xp (function write-apat)
+			"" "" ""))
+
+(define-ast-printer pp-pat-plus (object xp)
+  (declare (ignore object))
+  (write-string "+ " xp))
+
+(define-ast-printer pp-pat-negated (object xp)
+  (declare (ignore object))
+  (write-string "-" xp))
+
diff --git a/printers/printers.scm b/printers/printers.scm
new file mode 100644
index 0000000..3ac4fe6
--- /dev/null
+++ b/printers/printers.scm
@@ -0,0 +1,28 @@
+;;; printers.scm -- compilation unit definition for structure printers
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  3 Jan 1992
+;;;
+;;;
+
+(define-compilation-unit printer-support
+  (source-filename "$Y2/printers/")
+  (require global)
+  (unit util
+	(source-filename "util.scm")))
+
+(define-compilation-unit printers
+  (source-filename "$Y2/printers/")
+  (require printer-support)
+  (unit print-exps
+	(source-filename "print-exps.scm"))
+  (unit print-modules
+	(source-filename "print-modules.scm"))
+  (unit print-types
+	(source-filename "print-types.scm"))
+  (unit print-ntypes
+	(source-filename "print-ntypes.scm"))
+  (unit print-valdefs
+	(source-filename "print-valdefs.scm"))
+  )
+
diff --git a/printers/util.scm b/printers/util.scm
new file mode 100644
index 0000000..498aa25
--- /dev/null
+++ b/printers/util.scm
@@ -0,0 +1,214 @@
+;;; util.scm -- utilities for printing AST structures
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  15 Jan 1992
+;;;
+;;;
+
+
+;;; The AST syntax printers are only used if this variable is true.
+
+(define *print-ast-syntax* '#t)
+
+
+;;; Here's a macro for defining AST printers.
+
+(define-syntax (define-ast-printer type lambda-list . body)
+  (let ((printer  (symbol-append 'write- type)))
+    `(begin
+       (define (,printer ,@lambda-list) ,@body)
+       (define-struct-printer ,type ,printer))
+    ))
+
+
+;;; This variable controls how much indentation to perform on block
+;;; bodies.
+
+(define *print-ast-indent* 2)
+
+
+;;; Begin a logical block with the default indentation.
+
+(define-syntax (with-ast-block xp-stuff . body)
+  (let ((xp  (car xp-stuff)))
+    `(pprint-logical-block (,xp '() "" "")
+       (pprint-indent 'block (dynamic *print-ast-indent*) ,xp)
+       (pprint-pop)  ; prevents unused variable warning
+       ,@body)))
+
+
+;;; Write a space and maybe a fill line break.
+
+(define (write-whitespace xp)
+  (write-char #\space xp)
+  (pprint-newline 'fill xp))
+
+
+;;; Write a space and maybe a mandatory line break.
+
+(define (write-newline xp)
+  (write-char #\space xp)
+  (pprint-newline 'mandatory xp))
+
+
+
+;;; Write a list of things separated by delimiters and maybe
+;;; surrounded by delimiters.
+
+(define (write-delimited-list objects xp fn delim prefix suffix)
+  (pprint-logical-block (xp '() prefix suffix)
+    (do ((objects objects (cdr objects)))
+	((null? objects) '#f)
+	(pprint-pop)
+	(funcall fn (car objects) xp)
+	(when (cdr objects)
+	  (write-string delim xp)
+	  (write-whitespace xp)))))
+
+
+;;; Here's a couple common special cases of the above.
+
+(define (write-commaized-list objects xp)
+  (write-delimited-list objects xp (function write) "," "(" ")"))
+
+(define (write-ordinary-list objects xp)
+  (write-delimited-list objects xp (function write) "" "" ""))
+
+
+;;; Here's another helper function that's used to implement the layout
+;;; rule.  The layout rule is only used to format output if *print-pretty*
+;;; is true.
+;;; *** should do pprint-indent here?
+
+(define (write-layout-rule objects xp fn)
+  (pprint-logical-block (xp '()
+			    (if (dynamic *print-pretty*) "" "{")
+			    (if (dynamic *print-pretty*) "" "}"))
+    (do ((objects objects (cdr objects)))
+	((null? objects) '#f)
+	(pprint-pop)
+	(funcall fn (car objects) xp)
+	(when (cdr objects)
+	  (if (dynamic *print-pretty*)
+	      (pprint-newline 'mandatory xp)
+	      (write-string "; " xp))))))
+
+
+;;; This filters a list of decls, removing the recursive marker added by
+;;; dependency analysis.
+
+(define (remove-recursive-grouping decls)
+  (cond ((null? decls) '())
+	((is-type? 'recursive-decl-group (car decls))
+	 (append (recursive-decl-group-decls (car decls))
+		 (remove-recursive-grouping (cdr decls))))
+	(else
+	 (cons (car decls) (remove-recursive-grouping (cdr decls))))))
+
+;;; Write where-decls, using the layout rule if appropriate.
+
+(define (write-wheredecls decls xp)
+  (when (not (null? decls))
+    (write-whitespace xp)
+    (write-string "where" xp)
+    (write-whitespace xp)
+    (write-layout-rule (remove-recursive-grouping decls) xp (function write))))
+
+
+;;; Write an ordinary variable name.
+
+(define (write-avarid name xp)
+  (write-string (symbol->string name) xp))
+  
+
+;;; Constructor name symbols have a funny prefix attached; have to strip
+;;; this off, so can't just print the symbol using write-avarid.
+
+(define (write-aconid name xp)
+  (let ((s  (symbol->string name)))
+    (write-string (substring s 1 (string-length s)) xp)))
+
+
+;;; There are a couple places where conids and varids are mixed up
+;;; together.
+
+(define (conid? name)
+  (eqv? (string-ref (symbol->string name) 0) #\;))
+
+(define (write-varop-conop name xp)
+  (if (conid? name)
+      (write-conop name xp)
+      (write-varop name xp)))
+
+(define (write-varid-conid name xp)
+  (if (conid? name)
+      (write-conid name xp)
+      (write-varid name xp)))
+
+
+
+;;; Stuff for writing a variable name as either an operator or an ordinary
+;;; variable ID.  This is necessary because some kinds of symbol names
+;;; default to being operators and others default to being ordinary names.
+;;; Bleah....
+
+
+(define (write-varop name xp)
+  (if (avarid? name)
+      (begin
+        (write-char #\` xp)
+	(write-avarid name xp)
+	(write-char #\` xp))
+      (write-avarid name xp)))
+
+(define (write-varid name xp)
+  (if (avarid? name)
+      (write-avarid name xp)
+      (begin
+        (write-char #\( xp)
+	(write-avarid name xp)
+	(write-char #\) xp))))
+
+
+;;; This tests for alphabetic rather than lower-case characters
+;;; so that gensym'ed variables with uppercase names don't print funny.
+
+(define (avarid? name)
+  (let ((ch  (string-ref (symbol->string name) 0)))
+    (char-alphabetic? ch)))
+
+
+;;; Similar stuff for doing constructor names.  Moby bleah....
+
+(define (write-conop name xp)
+  (if (aconid? name)
+      (begin
+        (write-char #\` xp)
+	(write-aconid name xp)
+	(write-char #\` xp))
+      (write-aconid name xp)))
+
+(define (write-conid name xp)
+  (if (aconid? name)
+      (write-aconid name xp)
+      (begin
+        (write-char #\( xp)
+	(write-aconid name xp)
+	(write-char #\) xp))))
+
+(define (aconid? name)
+  (let ((ch  (string-ref (symbol->string name) 1)))
+    (char-upper-case? ch)))
+
+
+;;; These are officially aconid in the syntax, but they aren't
+;;; prefixed so write them using write-avarid instead.  Barf.
+
+(define (write-modid name xp)
+  (write-avarid name xp))
+
+(define (write-tyconid name xp)
+  (write-avarid name xp))
+
+(define (write-tyclsid name xp)
+  (write-avarid name xp))