/[cmucl]/src/code/pprint-loop.lisp
ViewVC logotype

Contents of /src/code/pprint-loop.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Fri Mar 19 15:18:59 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.2: +1 -1 lines
Merge intl-branch 2010-03-18 to HEAD.  To build, you need to use
boot-2010-02-1 as the bootstrap file.  You should probably also use
the new -P option for build.sh to generate and update the po files
while building.
1 ;;; -*- Mode: lisp; Package: PRETTY-PRINT -*-
2 ;;; Pretty printer for loop and various other utilities.
3 ;;; This is taken from Dick Water's XP. The license contained therein says:
4 ;;;
5 ;;; Permission to use, copy, modify, and distribute this software and its
6 ;;; documentation for any purpose and without fee is hereby granted,
7 ;;; provided that this copyright and permission notice appear in all
8 ;;; copies and supporting documentation, and that the name of M.I.T. not
9 ;;; be used in advertising or publicity pertaining to distribution of the
10 ;;; software without specific, written prior permission. M.I.T. makes no
11 ;;; representations about the suitability of this software for any
12 ;;; purpose. It is provided "as is" without express or implied warranty.
13 ;;;
14 ;;; M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
15 ;;; ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
16 ;;; M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
17 ;;; ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
18 ;;; WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
19 ;;; ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
20 ;;; SOFTWARE.
21
22 ;; The challenge here is that we have to effectively parse the clauses
23 ;; of the loop in order to know how to print things. Also you want to
24 ;; do this in a purely incremental way so that all of the abbreviation
25 ;; things work, and you wont blow up on circular lists or the like.
26 ;; (More aesthic output could be produced by really parsing the
27 ;; clauses into nested lists before printing them.)
28 ;;
29 ;; The following program assumes the following simplified grammar of
30 ;; the loop clauses that explains how to print them. Note that it
31 ;; does not bare much resemblence to the right parsing grammar,
32 ;; however, it produces half decent output. The way to make the
33 ;; output better is to make the grammar more detailed.
34 ;;
35 ;; loop == (LOOP {clause}*) ;one clause on each line.
36 ;; clause == block | linear | cond | finally
37 ;; block == block-head {expr}* ;as many exprs as possible on each line.
38 ;; linear == linear-head {expr}* ;one expr on each line.
39 ;; finally == FINALLY [DO | DOING | RETURN] {expr}* ;one expr on each line.
40 ;; cond == cond-head [expr]
41 ;; clause
42 ;; {AND clause}* ;one AND on each line.
43 ;; [ELSE
44 ;; clause
45 ;; {AND clause}*] ;one AND on each line.
46 ;; [END]
47 ;; block-head == FOR | AS | WITH | AND
48 ;; | REPEAT | NAMED | WHILE | UNTIL | ALWAYS | NEVER | THEREIS | RETURN
49 ;; | COLLECT | COLLECTING | APPEND | APPENDING | NCONC | NCONCING | COUNT
50 ;; | COUNTING | SUM | SUMMING | MAXIMIZE | MAXIMIZING | MINIMIZE | MINIMIZING
51 ;; linear-head == DO | DOING | INITIALLY
52 ;; var-head == FOR | AS | WITH
53 ;; cond-head == IF | WHEN | UNLESS
54 ;; expr == <anything that is not a head symbol>
55 ;;
56 ;; Note all the string comparisons below are required to support some
57 ;; existing implementations of LOOP.
58
59 (in-package "PRETTY-PRINT")
60 (intl:textdomain "cmucl")
61 (defun pprint-loop-token-type (token &aux string)
62 (cond ((not (symbolp token)) :expr)
63 ((string= (setq string (string token)) "FINALLY") :finally)
64 ((member string '("IF" "WHEN" "UNLESS") :test #'string=) :cond-head)
65 ((member string '("DO" "DOING" "INITIALLY") :test #'string=) :linear-head)
66 ((member string '("FOR" "AS" "WITH" "AND" "END" "ELSE"
67 "REPEAT" "NAMED" "WHILE" "UNTIL" "ALWAYS" "NEVER"
68 "THEREIS" "RETURN" "COLLECT" "COLLECTING" "APPEND"
69 "APPENDING" "NCONC" "NCONCING" "COUNT" "COUNTING"
70 "SUM" "SUMMING" "MAXIMIZE" "MAXIMIZING"
71 "MINIMIZE" "MINIMIZING")
72 :test #'string=)
73 :block-head)
74 (T :expr)))
75
76 (defun pprint-loop (xp loop)
77 (if (not (and (consp (cdr loop)) (symbolp (cadr loop)))) ; old-style loop
78 (funcall (formatter "~:<~W~^~2I~@:_~@{~W~^~_~}~:>")
79 xp loop)
80 (progn
81 (pprint-logical-block (xp loop :prefix "(" :suffix ")")
82 (let (token type)
83 (labels ((next-token ()
84 (pprint-exit-if-list-exhausted)
85 (setq token (pprint-pop))
86 (setq type (pprint-loop-token-type token)))
87 (print-clause (xp)
88 (case type
89 (:linear-head (print-exprs xp nil :mandatory))
90 (:cond-head (print-cond xp))
91 (:finally (print-exprs xp T :mandatory))
92 (otherwise (print-exprs xp nil :fill))))
93 (print-exprs (xp skip-first-non-expr newline-type)
94 (let ((first token))
95 (next-token) ;so always happens no matter what
96 (pprint-logical-block (xp nil)
97 (write first :stream xp)
98 (when (and skip-first-non-expr (not (eq type :expr)))
99 (write-char #\space xp)
100 (write token :stream xp)
101 (next-token))
102 (when (eq type :expr)
103 (write-char #\space xp)
104 (pprint-indent :current 0 xp)
105 (loop (write token :stream xp)
106 (next-token)
107 (when (not (eq type :expr))
108 (return nil))
109 (write-char #\space xp)
110 (pprint-newline newline-type xp))))))
111 (print-cond (xp)
112 (let ((first token))
113 (next-token) ;so always happens no matter what
114 (pprint-logical-block (xp nil)
115 (write first :stream xp)
116 (when (eq type :expr)
117 (write-char #\space xp)
118 (write token :stream xp)
119 (next-token))
120 (write-char #\space xp)
121 (pprint-indent :block 2 xp)
122 (pprint-newline :linear xp)
123 (print-clause xp)
124 (print-and-list xp)
125 (when (and (symbolp token)
126 (string= (string token) "ELSE"))
127 (print-else-or-end xp)
128 (write-char #\space xp)
129 (pprint-newline :linear xp)
130 (print-clause xp)
131 (print-and-list xp))
132 (when (and (symbolp token)
133 (string= (string token) "END"))
134 (print-else-or-end xp)))))
135 (print-and-list (xp)
136 (loop (when (not (and (symbolp token)
137 (string= (string token) "AND")))
138 (return nil))
139 (write-char #\space xp)
140 (pprint-newline :mandatory xp)
141 (write token :stream xp)
142 (next-token)
143 (write-char #\space xp)
144 (print-clause xp)))
145 (print-else-or-end (xp)
146 (write-char #\space xp)
147 (pprint-indent :block 0 xp)
148 (pprint-newline :linear xp)
149 (write token :stream xp)
150 (next-token)
151 (pprint-indent :block 2 xp)))
152 ;;(pprint-exit-if-list-exhausted)
153 (write (pprint-pop) :stream xp)
154 (next-token)
155 (write-char #\space xp)
156 (pprint-indent :current 0 xp)
157 (loop (print-clause xp)
158 (write-char #\space xp)
159 (pprint-newline :linear xp))))))))
160
161 ;;; LOOP-PP-INIT -- interface
162 ;;;
163 ;;; This is called by PPRINT-INIT. This enables the pretty printer
164 ;;; for loops. We need this so that loop pprinter is enabled at the
165 ;;; right time, since this is in a file separate from pprint.lisp.
166 ;;;
167 (defun loop-pp-init ()
168 (set-pprint-dispatch '(cons (eql loop)) #'pprint-loop))

  ViewVC Help
Powered by ViewVC 1.1.5