Forked from
cmucl / cmucl
1326 commits behind the upstream repository.
-
Raymond Toy authoredRaymond Toy authored
pprint-loop.lisp 6.77 KiB
;;; -*- 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")
(intl:textdomain "cmucl")
(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))