From becd405564f5d75d958246f34cf21a4a5b9e6673 Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Thu, 14 Oct 2004 13:53:19 +0000
Subject: [PATCH] Move the loop pretty-printer to its own file because of the
 MIT license.

pprint-loop.lisp:
  o New file containing the loop pprinter, with XP license

pprint.lisp:
  o Remove loop pprinter code.
  o Call initializer to enable the loop pprinter at the right time.

worldcom.lisp:
  o Compile pprint-loop

worldload.lisp:
  o Load pprint-loop at the right time.
---
 code/pprint-loop.lisp | 168 ++++++++++++++++++++++++++++++++++++++++++
 code/pprint.lisp      | 148 +------------------------------------
 tools/worldcom.lisp   |   3 +-
 tools/worldload.lisp  |   4 +-
 4 files changed, 177 insertions(+), 146 deletions(-)
 create mode 100644 code/pprint-loop.lisp

diff --git a/code/pprint-loop.lisp b/code/pprint-loop.lisp
new file mode 100644
index 000000000..ab3bc53b1
--- /dev/null
+++ b/code/pprint-loop.lisp
@@ -0,0 +1,168 @@
+;;; -*- Mode: lisp; Package PRETTY-PRINT -*-
+;;; Pretty printer for loop and various other utilities.
+;;; This is taken from Dick Water's XP.  The license contained therein says:
+;;;
+;;; Permission to use, copy, modify, and distribute this software and its
+;;; documentation for any purpose and without fee is hereby granted,
+;;; provided that this copyright and permission notice appear in all
+;;; copies and supporting documentation, and that the name of M.I.T. not
+;;; be used in advertising or publicity pertaining to distribution of the
+;;; software without specific, written prior permission. M.I.T. makes no
+;;; representations about the suitability of this software for any
+;;; purpose.  It is provided "as is" without express or implied warranty.
+;;;
+;;;    M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
+;;;    ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
+;;;    M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
+;;;    ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
+;;;    WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
+;;;    ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
+;;;    SOFTWARE.
+
+;; The challenge here is that we have to effectively parse the clauses
+;; of the loop in order to know how to print things.  Also you want to
+;; do this in a purely incremental way so that all of the abbreviation
+;; things work, and you wont blow up on circular lists or the like.
+;; (More aesthic output could be produced by really parsing the
+;; clauses into nested lists before printing them.)
+;;
+;; The following program assumes the following simplified grammar of
+;; the loop clauses that explains how to print them.  Note that it
+;; does not bare much resemblence to the right parsing grammar,
+;; however, it produces half decent output.  The way to make the
+;; output better is to make the grammar more detailed.
+;;
+;; loop == (LOOP {clause}*)      ;one clause on each line.
+;; clause == block | linear | cond | finally
+;; block == block-head {expr}*   ;as many exprs as possible on each line.
+;; linear == linear-head {expr}* ;one expr on each line.
+;; finally == FINALLY [DO | DOING | RETURN] {expr}* ;one expr on each line.
+;; cond == cond-head [expr]
+;;           clause
+;;	    {AND clause}*       ;one AND on each line.
+;;         [ELSE
+;;           clause
+;;	    {AND clause}*]      ;one AND on each line.
+;;         [END]
+;; block-head == FOR | AS | WITH | AND
+;;               | REPEAT | NAMED | WHILE | UNTIL | ALWAYS | NEVER | THEREIS | RETURN
+;;               | COLLECT | COLLECTING | APPEND | APPENDING | NCONC | NCONCING | COUNT
+;;               | COUNTING | SUM | SUMMING | MAXIMIZE | MAXIMIZING | MINIMIZE | MINIMIZING 
+;; linear-head == DO | DOING | INITIALLY
+;; var-head == FOR | AS | WITH
+;; cond-head == IF | WHEN | UNLESS
+;; expr == <anything that is not a head symbol>
+;;
+;; Note all the string comparisons below are required to support some
+;; existing implementations of LOOP.
+
+(in-package "PRETTY-PRINT")
+
+(defun pprint-loop-token-type (token &aux string)
+  (cond ((not (symbolp token)) :expr)
+	((string= (setq string (string token)) "FINALLY") :finally)
+	((member string '("IF" "WHEN" "UNLESS") :test #'string=) :cond-head)
+	((member string '("DO" "DOING" "INITIALLY") :test #'string=) :linear-head)
+	((member string '("FOR" "AS" "WITH" "AND" "END" "ELSE"
+			  "REPEAT" "NAMED" "WHILE" "UNTIL" "ALWAYS" "NEVER"
+			  "THEREIS" "RETURN" "COLLECT" "COLLECTING" "APPEND"
+			  "APPENDING" "NCONC" "NCONCING" "COUNT" "COUNTING"
+			  "SUM" "SUMMING" "MAXIMIZE" "MAXIMIZING"
+			  "MINIMIZE" "MINIMIZING")
+		 :test #'string=)
+	 :block-head)
+	(T :expr)))
+
+(defun pprint-loop (xp loop)
+  (if (not (and (consp (cdr loop)) (symbolp (cadr loop)))) ; old-style loop
+      (funcall (formatter "~:<~W~^~2I~@:_~@{~W~^~_~}~:>")
+	       xp loop)
+      (progn
+	(pprint-logical-block (xp loop :prefix "(" :suffix ")")
+	  (let (token type)
+	    (labels ((next-token ()
+		       (pprint-exit-if-list-exhausted)
+		       (setq token (pprint-pop))
+		       (setq type (pprint-loop-token-type token)))
+		     (print-clause (xp)
+		       (case type
+			 (:linear-head (print-exprs xp nil :mandatory))
+			 (:cond-head (print-cond xp))
+			 (:finally (print-exprs xp T :mandatory))
+			 (otherwise (print-exprs xp nil :fill))))
+		     (print-exprs (xp skip-first-non-expr newline-type)
+		       (let ((first token))
+			 (next-token) ;so always happens no matter what
+			 (pprint-logical-block (xp nil)
+			   (write first :stream xp)
+			   (when (and skip-first-non-expr (not (eq type :expr)))
+			     (write-char #\space xp)
+			     (write token :stream xp)
+			     (next-token))
+			   (when (eq type :expr)
+			     (write-char #\space xp)
+			     (pprint-indent :current 0 xp)
+			     (loop (write token :stream xp)
+				(next-token)
+				(when (not (eq type :expr))
+				  (return nil))
+				(write-char #\space xp)
+				(pprint-newline newline-type xp))))))
+		     (print-cond (xp)
+		       (let ((first token))
+			 (next-token) ;so always happens no matter what
+			 (pprint-logical-block (xp nil)
+			   (write first :stream xp)
+			   (when (eq type :expr)
+			     (write-char #\space xp)
+			     (write token :stream xp)
+			     (next-token))
+			   (write-char #\space xp)
+			   (pprint-indent :block 2 xp)
+			   (pprint-newline :linear xp)
+			   (print-clause xp)
+			   (print-and-list xp)
+			   (when (and (symbolp token)
+				      (string= (string token) "ELSE"))
+			     (print-else-or-end xp)
+			     (write-char #\space xp)
+			     (pprint-newline :linear xp)
+			     (print-clause xp)
+			     (print-and-list xp))
+			   (when (and (symbolp token)
+				      (string= (string token) "END"))
+			     (print-else-or-end xp)))))
+		     (print-and-list (xp)
+		       (loop (when (not (and (symbolp token)
+					     (string= (string token) "AND")))
+			       (return nil))
+			  (write-char #\space xp)
+			  (pprint-newline :mandatory xp)
+			  (write token :stream xp)
+			  (next-token)
+			  (write-char #\space xp)
+			  (print-clause xp)))
+		     (print-else-or-end (xp)
+		       (write-char #\space xp)
+		       (pprint-indent :block 0 xp)
+		       (pprint-newline :linear xp)
+		       (write token :stream xp)
+		       (next-token)
+		       (pprint-indent :block 2 xp)))
+	      ;;(pprint-exit-if-list-exhausted)
+	      (write (pprint-pop) :stream xp)
+	      (next-token)
+	      (write-char #\space xp)
+	      (pprint-indent :current 0 xp)
+	      (loop (print-clause xp)
+		 (write-char #\space xp)
+		 (pprint-newline :linear xp))))))))
+
+;;; LOOP-PP-INIT -- interface
+;;;
+;;; This is called by PPRINT-INIT.  This enables the pretty printer
+;;; for loops.  We need this so that loop pprinter is enabled at the
+;;; right time, since this is in a file separate from pprint.lisp.
+;;;
+(defun loop-pp-init ()
+  (set-pprint-dispatch '(cons (eql loop)) #'pprint-loop))
diff --git a/code/pprint.lisp b/code/pprint.lisp
index d8792e0be..d856b4573 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.47 2004/10/09 14:38:32 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pprint.lisp,v 1.48 2004/10/14 13:53:19 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1460,147 +1460,6 @@
   (funcall (formatter "~:<~W~^~3I ~:_~W~^~1I~@{ ~@:_~W~}~:>")
 	   stream list))
 
-
-;;; Pretty printer for loop and various other utilities.
-;;; This is taken from Dick Water's XP.
-
-;; The challenge here is that we have to effectively parse the clauses
-;; of the loop in order to know how to print things.  Also you want to
-;; do this in a purely incremental way so that all of the abbreviation
-;; things work, and you wont blow up on circular lists or the like.
-;; (More aesthic output could be produced by really parsing the
-;; clauses into nested lists before printing them.)
-;;
-;; The following program assumes the following simplified grammar of
-;; the loop clauses that explains how to print them.  Note that it
-;; does not bare much resemblence to the right parsing grammar,
-;; however, it produces half decent output.  The way to make the
-;; output better is to make the grammar more detailed.
-;;
-;; loop == (LOOP {clause}*)      ;one clause on each line.
-;; clause == block | linear | cond | finally
-;; block == block-head {expr}*   ;as many exprs as possible on each line.
-;; linear == linear-head {expr}* ;one expr on each line.
-;; finally == FINALLY [DO | DOING | RETURN] {expr}* ;one expr on each line.
-;; cond == cond-head [expr]
-;;           clause
-;;	    {AND clause}*       ;one AND on each line.
-;;         [ELSE
-;;           clause
-;;	    {AND clause}*]      ;one AND on each line.
-;;         [END]
-;; block-head == FOR | AS | WITH | AND
-;;               | REPEAT | NAMED | WHILE | UNTIL | ALWAYS | NEVER | THEREIS | RETURN
-;;               | COLLECT | COLLECTING | APPEND | APPENDING | NCONC | NCONCING | COUNT
-;;               | COUNTING | SUM | SUMMING | MAXIMIZE | MAXIMIZING | MINIMIZE | MINIMIZING 
-;; linear-head == DO | DOING | INITIALLY
-;; var-head == FOR | AS | WITH
-;; cond-head == IF | WHEN | UNLESS
-;; expr == <anything that is not a head symbol>
-;;
-;; Note all the string comparisons below are required to support some
-;; existing implementations of LOOP.
-
-(defun pprint-loop-token-type (token &aux string)
-  (cond ((not (symbolp token)) :expr)
-	((string= (setq string (string token)) "FINALLY") :finally)
-	((member string '("IF" "WHEN" "UNLESS") :test #'string=) :cond-head)
-	((member string '("DO" "DOING" "INITIALLY") :test #'string=) :linear-head)
-	((member string '("FOR" "AS" "WITH" "AND" "END" "ELSE"
-			  "REPEAT" "NAMED" "WHILE" "UNTIL" "ALWAYS" "NEVER"
-			  "THEREIS" "RETURN" "COLLECT" "COLLECTING" "APPEND"
-			  "APPENDING" "NCONC" "NCONCING" "COUNT" "COUNTING"
-			  "SUM" "SUMMING" "MAXIMIZE" "MAXIMIZING"
-			  "MINIMIZE" "MINIMIZING")
-		 :test #'string=)
-	 :block-head)
-	(T :expr)))
-
-(defun pprint-loop (xp loop)
-  (if (not (and (consp (cdr loop)) (symbolp (cadr loop)))) ; old-style loop
-      (funcall (formatter "~:<~W~^~2I~@:_~@{~W~^~_~}~:>")
-	       xp loop)
-      (progn
-	(pprint-logical-block (xp loop :prefix "(" :suffix ")")
-	  (let (token type)
-	    (labels ((next-token ()
-		       (pprint-exit-if-list-exhausted)
-		       (setq token (pprint-pop))
-		       (setq type (pprint-loop-token-type token)))
-		     (print-clause (xp)
-		       (case type
-			 (:linear-head (print-exprs xp nil :mandatory))
-			 (:cond-head (print-cond xp))
-			 (:finally (print-exprs xp T :mandatory))
-			 (otherwise (print-exprs xp nil :fill))))
-		     (print-exprs (xp skip-first-non-expr newline-type)
-		       (let ((first token))
-			 (next-token) ;so always happens no matter what
-			 (pprint-logical-block (xp nil)
-			   (write first :stream xp)
-			   (when (and skip-first-non-expr (not (eq type :expr)))
-			     (write-char #\space xp)
-			     (write token :stream xp)
-			     (next-token))
-			   (when (eq type :expr)
-			     (write-char #\space xp)
-			     (pprint-indent :current 0 xp)
-			     (loop (write token :stream xp)
-				(next-token)
-				(when (not (eq type :expr))
-				  (return nil))
-				(write-char #\space xp)
-				(pprint-newline newline-type xp))))))
-		     (print-cond (xp)
-		       (let ((first token))
-			 (next-token) ;so always happens no matter what
-			 (pprint-logical-block (xp nil)
-			   (write first :stream xp)
-			   (when (eq type :expr)
-			     (write-char #\space xp)
-			     (write token :stream xp)
-			     (next-token))
-			   (write-char #\space xp)
-			   (pprint-indent :block 2 xp)
-			   (pprint-newline :linear xp)
-			   (print-clause xp)
-			   (print-and-list xp)
-			   (when (and (symbolp token)
-				      (string= (string token) "ELSE"))
-			     (print-else-or-end xp)
-			     (write-char #\space xp)
-			     (pprint-newline :linear xp)
-			     (print-clause xp)
-			     (print-and-list xp))
-			   (when (and (symbolp token)
-				      (string= (string token) "END"))
-			     (print-else-or-end xp)))))
-		     (print-and-list (xp)
-		       (loop (when (not (and (symbolp token)
-					     (string= (string token) "AND")))
-			       (return nil))
-			  (write-char #\space xp)
-			  (pprint-newline :mandatory xp)
-			  (write token :stream xp)
-			  (next-token)
-			  (write-char #\space xp)
-			  (print-clause xp)))
-		     (print-else-or-end (xp)
-		       (write-char #\space xp)
-		       (pprint-indent :block 0 xp)
-		       (pprint-newline :linear xp)
-		       (write token :stream xp)
-		       (next-token)
-		       (pprint-indent :block 2 xp)))
-	      ;;(pprint-exit-if-list-exhausted)
-	      (write (pprint-pop) :stream xp)
-	      (next-token)
-	      (write-char #\space xp)
-	      (pprint-indent :current 0 xp)
-	      (loop (print-clause xp)
-		 (write-char #\space xp)
-		 (pprint-newline :linear xp))))))))
-
 
 ;;;; Interface seen by regular (ugly) printer and initialization routines.
 
@@ -1663,7 +1522,7 @@
     (etypecase pprint-typecase)
     (handler-bind pprint-handler-bind)
     (handler-case pprint-handler-bind)
-    (loop pprint-loop)
+    #+nil(loop pprint-loop)
     (multiple-value-bind pprint-multiple-value-bind)
     (multiple-value-setq pprint-block)
     (pprint-logical-block pprint-block)
@@ -1717,7 +1576,8 @@
       (set-pprint-dispatch `(cons (eql ,(first magic-form)))
 			   (symbol-function (second magic-form))))
     ;; Other pretty-print init forms.
-    (lisp::backq-pp-init))
+    (lisp::backq-pp-init)
+    (loop-pp-init))
 
   (setf *print-pprint-dispatch* (copy-pprint-dispatch nil))
   (setf *pretty-printer* #'output-pretty-object)
diff --git a/tools/worldcom.lisp b/tools/worldcom.lisp
index e32c44884..4a1cb2dc9 100644
--- a/tools/worldcom.lisp
+++ b/tools/worldcom.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldcom.lisp,v 1.93 2004/07/25 18:29:10 pmai Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldcom.lisp,v 1.94 2004/10/14 13:53:19 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -226,6 +226,7 @@
 (comf "target:code/print")
 (comf "target:code/pprint")
 #-no-runtime (comf "target:code/pprint" :byte-compile t)
+(comf "target:code/pprint-loop")
 (comf "target:code/format")
 #-no-runtime (comf "target:code/format" :byte-compile t)
 (comf "target:code/package")
diff --git a/tools/worldload.lisp b/tools/worldload.lisp
index 623f076e1..48dc8f7bb 100644
--- a/tools/worldload.lisp
+++ b/tools/worldload.lisp
@@ -6,7 +6,7 @@
 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldload.lisp,v 1.103 2004/06/01 23:43:03 cwang Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/tools/worldload.lisp,v 1.104 2004/10/14 13:53:19 rtoy Exp $
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -40,6 +40,7 @@
 ;;; Load the rest of the reader (maybe byte-compiled.)
 (maybe-byte-load "target:code/sharpm")
 (maybe-byte-load "target:code/backq")
+(maybe-byte-load "target:code/pprint-loop")
 (setq std-lisp-readtable (copy-readtable *readtable*))
 
 ;;; The pretty printer is part of the kernel core, but we don't turn it in
@@ -142,6 +143,7 @@
   (byte-load-over "target:code/debug")
   (byte-load-over "target:code/error")
   (maybe-byte-load "target:code/pprint" nil)
+  (maybe-byte-load "target:code/pprint-loop" nil)
   (maybe-byte-load "target:code/format" nil)
   (maybe-byte-load "target:code/reader" nil)
   (maybe-byte-load "target:code/pathname" nil)
-- 
GitLab