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