From 87811b3ff2b56bd88f75c9248a65f4c83c557978 Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Fri, 22 Oct 2004 16:56:38 +0000
Subject: [PATCH] o Add pprinter for DEFPACKAGE, DEFMETHOD, and WHEN. o Modify
 PPRINT-FUNCTION-CALL to try to be a little smarter and print   keyword/value
 pairs on one line.  Note that this will be confused if   the function call
 uses keywords as arg values.  This will interpret   them as a keyword arg.  I
 left the original call in, just in case we   want to revert this.

---
 code/pprint.lisp | 76 +++++++++++++++++++++++++++++++++++++++++++++---
 1 file changed, 72 insertions(+), 4 deletions(-)

diff --git a/code/pprint.lisp b/code/pprint.lisp
index 2da017a67..139e2d42f 100644
--- a/code/pprint.lisp
+++ b/code/pprint.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pprint.lisp,v 1.49 2004/10/21 21:26:27 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pprint.lisp,v 1.50 2004/10/22 16:56:38 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1454,12 +1454,38 @@
     (pprint-fill stream (pprint-pop))
     (pprint-tagbody-guts stream)))
 
+#+nil
 (defun pprint-function-call (stream list &rest noise)
   (declare (ignore noise))
   (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~_~}~:>")
 	   stream
 	   list))
 
+(defun pprint-function-call (stream list &rest noise)
+  (declare (ignore noise))
+  (pprint-logical-block (stream list :prefix "(" :suffix ")")
+    (pprint-exit-if-list-exhausted)
+    ;; Function name
+    (output-object (pprint-pop) stream)
+    (pprint-exit-if-list-exhausted)
+    (write-char #\space stream)
+    (pprint-newline :fill stream)
+    (pprint-indent :current 0 stream)
+    ;; Output args.  We try to keep keyword/value pairs on the same
+    ;; line.  This, of course, doesn't work if the keyword isn't a
+    ;; keyword arg because that will mess up the following stuff if
+    ;; the next arg is really a keyword arg.
+    (loop
+       (let ((arg (pprint-pop)))
+	 (output-object arg stream)
+	 (pprint-exit-if-list-exhausted)
+	 (write-char #\space stream)
+	 (when (keywordp arg)
+	   (output-object (pprint-pop) stream)
+	   (pprint-exit-if-list-exhausted)
+	   (write-char #\space stream))
+	 (pprint-newline :linear stream)))))
+
 (defun pprint-with-like (stream list &rest noise)
   (declare (ignore noise))
   (funcall (formatter "~:<~W~^~3I ~:_~W~^~1I~@{ ~@:_~W~}~:>")
@@ -1507,7 +1533,40 @@
        (pprint-exit-if-list-exhausted)
        (pprint-newline :mandatory stream)
        (output-object (pprint-pop) stream))))
-  
+
+(defun pprint-defpackage (stream list &rest noise)
+  (declare (ignore noise))
+  (funcall (formatter "~:<~W ~W~I~@{~@:_ ~:<~@{~W~^~:I~@{ ~W~^~:_~}~}~:>~}~:>")
+	   stream list))
+
+(defun pprint-defmethod (stream list &rest noise)
+  (declare (ignore noise))
+  (pprint-logical-block (stream list :prefix "(" :suffix ")")
+    (output-object (pprint-pop) stream)
+    (pprint-exit-if-list-exhausted)
+    (write-char #\space stream)
+    (output-object (pprint-pop) stream)
+    (pprint-exit-if-list-exhausted)
+    ;; Print out method qualifiers, if any
+    (loop
+       (let ((qual-or-lambda (pprint-pop)))
+	 (write-char #\space stream)
+	 (cond ((listp qual-or-lambda)
+		;; Print out lambda-list
+		(pprint-lambda-list stream qual-or-lambda)
+		(return))
+	       (t
+		(output-object qual-or-lambda stream)))
+	 (pprint-exit-if-list-exhausted)))
+    ;; Rest of the forms
+    (pprint-newline :mandatory stream)
+    (pprint-indent :block 0 stream)
+    (loop
+       (write-char #\space stream)
+       (output-object (pprint-pop) stream)
+       (pprint-exit-if-list-exhausted)
+       (pprint-newline :linear stream))))
+
 (defun pprint-restart-case (stream list &rest noise)
   (declare (ignore noise))
   (pprint-logical-block (stream list :prefix "(" :suffix ")")
@@ -1537,6 +1596,12 @@
 	      (output-object (pprint-pop) stream)
 	      (pprint-exit-if-list-exhausted)
 	      (pprint-newline :linear stream)))))))
+
+(defun pprint-when (stream list &rest noise)
+  (declare (ignore noise))
+  (funcall (formatter "~:<~W~^~3I ~:_~W~I~@:_~@{ ~W~^~_~}~:>")
+	   stream list))
+
 
 ;;;; Interface seen by regular (ugly) printer and initialization routines.
 
@@ -1579,9 +1644,11 @@
     (cond pprint-cond)
     (ctypecase pprint-typecase)
     (defconstant pprint-block)
+    (define-condition pprint-defclass)
     (define-modify-macro pprint-defun)
     (define-setf-expander pprint-defun)
     (defmacro pprint-defun)
+    (defpackage pprint-defpackage)
     (defparameter pprint-block)
     (defsetf pprint-defun)
     (defstruct pprint-defstruct)
@@ -1618,8 +1685,8 @@
     (step pprint-progn)
     (time pprint-progn)
     (typecase pprint-typecase)
-    (unless pprint-block)
-    (when pprint-block)
+    (unless pprint-when)
+    (when pprint-when)
     (with-compilation-unit pprint-with-like)
     (with-condition-restarts pprint-with-like)
     (with-hash-table-iterator pprint-with-like)
@@ -1633,6 +1700,7 @@
 
     ;; CLOS things
     (defclass pprint-defclass)
+    (defmethod pprint-defmethod)
     (with-slots pprint-with-like)
     (with-accessors pprint-with-like)
     
-- 
GitLab