1 files changed, 410 insertions, 0 deletions
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))
+