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-valdefs.scm | 180 +++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 180 insertions(+)
 create mode 100644 printers/print-valdefs.scm

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

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))
+
-- 
cgit v1.2.3