| 1 | (setq rcs-pp- |
| 2 | "$Header: /usr/lib/lisp/RCS/pp.l,v 1.2 83/08/15 22:27:54 jkf Exp $") |
| 3 | |
| 4 | ;; |
| 5 | ;; pp.l -[Mon Aug 15 10:52:13 1983 by jkf]- |
| 6 | ;; |
| 7 | ;; pretty printer for franz lisp |
| 8 | ;; |
| 9 | |
| 10 | (declare (macros t)) |
| 11 | |
| 12 | (declare (special poport pparm1 pparm2 lpar rpar form linel)) |
| 13 | ; (declare (localf $patom1 $prd1 $prdf charcnt condclosefile)) |
| 14 | |
| 15 | ; ======================================= |
| 16 | ; pretty printer top level routine pp |
| 17 | ; |
| 18 | ; |
| 19 | ; calling form- (pp arg1 arg2 ... argn) |
| 20 | ; the args may be names of functions, atoms with associated values |
| 21 | ; or output descriptors. |
| 22 | ; if argi is: |
| 23 | ; an atom - it is assumed to be a function name, if there is no |
| 24 | ; function property associated with it,then it is assumed |
| 25 | ; to be an atom with a value |
| 26 | ; (P port)- port is the output port where the results of the |
| 27 | ; pretty printing will be sent. |
| 28 | ; poport is the default if no (P port) is given. |
| 29 | ; (F fname)- fname is a file name to write the results in |
| 30 | ; (A atmname) - means, treat this as an atom with a value, dont |
| 31 | ; check if it is the name of a function. |
| 32 | ; (E exp)- evaluate exp without printing anything |
| 33 | ; other - pretty-print the expression as is - no longer an error |
| 34 | ; |
| 35 | ; Also, rather than printing only a function defn or only a value, we will |
| 36 | ; let prettyprops decide which props to print. Finally, prettyprops will |
| 37 | ; follow the CMULisp format where each element is either a property |
| 38 | ; or a dotted pair of the form (prop . fn) where in order to print the |
| 39 | ; given property we call (fn id val prop). The special properties |
| 40 | ; function and value are used to denote those "properties" which |
| 41 | ; do not actually appear on the plist. |
| 42 | ; |
| 43 | ; [history of this code: originally came from Harvard Lisp, hacked to |
| 44 | ; work under franz at ucb, hacked to work at cmu and finally rehacked |
| 45 | ; to work without special cmu macros] |
| 46 | |
| 47 | (declare (special $outport$ $fileopen$ prettyprops)) |
| 48 | |
| 49 | (setq prettyprops '((comment . pp-comment) |
| 50 | (function . pp-function) |
| 51 | (value . pp-value))) |
| 52 | |
| 53 | ; printret is like print yet it returns the value printed, this is used |
| 54 | ; by pp |
| 55 | (def printret |
| 56 | (macro ($l$) |
| 57 | `(progn (print ,@(cdr $l$)) ,(cadr $l$)))) |
| 58 | |
| 59 | (def pp |
| 60 | (nlambda ($xlist$) |
| 61 | (prog ($gcprint $outport$ $cur$ $fileopen$ $prl$ $atm$) |
| 62 | |
| 63 | (setq $gcprint nil) ; don't print |
| 64 | ; gc messages in pp. |
| 65 | |
| 66 | (setq $outport$ poport) ; default port |
| 67 | ; check if more to do, if not close output file if it is |
| 68 | ; open and leave |
| 69 | |
| 70 | |
| 71 | toploop (cond ((null (setq $cur$ (car $xlist$))) |
| 72 | (condclosefile) |
| 73 | (terpr) |
| 74 | (return t))) |
| 75 | |
| 76 | (cond ((dtpr $cur$) |
| 77 | (cond ((equal 'P (car $cur$)) ; specifying a port |
| 78 | (condclosefile) ; close file if open |
| 79 | (setq $outport$ (eval (cadr $cur$)))) |
| 80 | |
| 81 | ((equal 'F (car $cur$)) ; specifying a file |
| 82 | (condclosefile) ; close file if open |
| 83 | (setq $outport$ (outfile (cadr $cur$)) |
| 84 | $fileopen$ t)) |
| 85 | |
| 86 | |
| 87 | ((equal 'E (car $cur$)) |
| 88 | (eval (cadr $cur$))) |
| 89 | |
| 90 | (t (pp-form $cur$ $outport$))) ;-DNC inserted |
| 91 | (go botloop))) |
| 92 | |
| 93 | |
| 94 | (mapc (function |
| 95 | (lambda (prop) |
| 96 | (prog (printer) |
| 97 | (cond ((dtpr prop) |
| 98 | (setq printer (cdr prop)) |
| 99 | (setq prop (car prop))) |
| 100 | (t (setq printer 'pp-prop))) |
| 101 | (cond ((eq 'value prop) |
| 102 | (and (boundp $cur$) |
| 103 | (apply printer |
| 104 | (list $cur$ |
| 105 | (eval $cur$) |
| 106 | 'value)) |
| 107 | (terpr $outport$))) |
| 108 | ((eq 'function prop) |
| 109 | (and (getd $cur$) |
| 110 | (cond ((not (bcdp (getd $cur$))) |
| 111 | (apply printer |
| 112 | (list $cur$ |
| 113 | (getd $cur$) |
| 114 | 'function))) |
| 115 | ; restore message about |
| 116 | ; bcd since otherwise you |
| 117 | ; just get nothing and |
| 118 | ; people were complaining. |
| 119 | ; - dhl. |
| 120 | #-cmu |
| 121 | (t |
| 122 | (msg N |
| 123 | "pp: function " |
| 124 | (or $cur$) |
| 125 | " is machine coded (bcd) ")) |
| 126 | ) |
| 127 | (terpri $outport$))) |
| 128 | ((get $cur$ prop) |
| 129 | (apply printer |
| 130 | (list $cur$ |
| 131 | (get $cur$ prop) |
| 132 | prop)) |
| 133 | (terpri $outport$)))))) |
| 134 | prettyprops) |
| 135 | |
| 136 | |
| 137 | botloop (setq $xlist$ (cdr $xlist$)) |
| 138 | |
| 139 | (go toploop)))) |
| 140 | |
| 141 | (setq pparm1 50 pparm2 100) |
| 142 | |
| 143 | ; -DNC These "prettyprinter parameters" are used to decide when we should |
| 144 | ; quit printing down the right margin and move back to the left - |
| 145 | ; Do it when the leftmargin > pparm1 and there are more than pparm2 |
| 146 | ; more chars to print in the expression |
| 147 | |
| 148 | ; cmu prefers dv instead of setq |
| 149 | |
| 150 | #+cmu |
| 151 | (def pp-value (lambda (i v p) |
| 152 | (terpri $outport$) |
| 153 | (pp-form (list 'dv i v) $outport$))) |
| 154 | |
| 155 | #-cmu |
| 156 | (def pp-value (lambda (i v p) |
| 157 | ;;(terpr $outport$) ;; pp-form does an initial terpr. |
| 158 | ;; we don't need two. |
| 159 | (pp-form `(setq ,i ',v) $outport$))) |
| 160 | |
| 161 | (def pp-function (lambda (i v p) |
| 162 | #+cmu (terpri $outport$) |
| 163 | ;; |
| 164 | ;; add test for traced functions and don't |
| 165 | ;; print the trace mess, just the original |
| 166 | ;; function. - dhl. |
| 167 | ;; |
| 168 | ;; this test might belong in the main pp |
| 169 | ;; loop but fits in easily here. - dhl |
| 170 | ;; |
| 171 | (cond ((and (dtpr v) |
| 172 | (dtpr (cadr v)) |
| 173 | (memq (caadr v) |
| 174 | '(T-nargs T-arglist)) |
| 175 | (cond ((bcdp (get i 'trace-orig-fcn)) |
| 176 | #-cmu |
| 177 | (msg N |
| 178 | "pp: function " |
| 179 | (or i) |
| 180 | " is machine coded (bcd) ") |
| 181 | t) |
| 182 | (t (pp-form |
| 183 | (list 'def i |
| 184 | (get i 'trace-orig-fcn)) |
| 185 | $outport$) |
| 186 | t)))) |
| 187 | ; this function need to return t, but |
| 188 | ; pp-form returns nil sometimes. |
| 189 | (t (pp-form (list 'def i v) $outport$) |
| 190 | t)))) |
| 191 | |
| 192 | (def pp-prop (lambda (i v p) |
| 193 | #+cmu (terpri $outport$) |
| 194 | (pp-form (list 'defprop i v p) $outport$))) |
| 195 | |
| 196 | (def condclosefile |
| 197 | (lambda nil |
| 198 | (cond ($fileopen$ |
| 199 | (terpr $outport$) |
| 200 | (close $outport$) |
| 201 | (setq $fileopen$ nil))))) |
| 202 | \f |
| 203 | ; |
| 204 | ; these routines are meant to be used by pp but since |
| 205 | ; some people insist on using them we will set $outport$ to nil |
| 206 | ; as the default |
| 207 | (setq $outport$ nil) |
| 208 | |
| 209 | |
| 210 | |
| 211 | (defun pp-form (value &optional ($outport$ poport oport-p) (lmar 0)) |
| 212 | ($prdf value lmar 0)) |
| 213 | |
| 214 | ; this is for compatability with old code, will remove soon -- jkf |
| 215 | (def $prpr (lambda (x) (pp-form x $outport$))) |
| 216 | |
| 217 | |
| 218 | \f |
| 219 | (declare (special rmar)) ; -DNC this used to be m - I've tried to |
| 220 | ; to fix up the pretty printer a bit. It |
| 221 | ; used to mess up regularly on (a b .c) types |
| 222 | ; of lists. Also printmacros have been added. |
| 223 | |
| 224 | (def $prdf |
| 225 | (lambda (l lmar rmar) |
| 226 | (prog nil |
| 227 | ; |
| 228 | ; - DNC - Here we try to fix the tendency to print a |
| 229 | ; thin column down the right margin by allowing it |
| 230 | ; to move back to the left if necessary. |
| 231 | ; |
| 232 | (cond ((and (>& lmar pparm1) (>& (flatc l (1+ pparm2)) pparm2)) |
| 233 | (terpri $outport$) |
| 234 | (patom "; <<<<< start back on the left <<<<<" $outport$) |
| 235 | ($prdf l 5 0) |
| 236 | (terpri $outport$) |
| 237 | (patom "; >>>>> continue on the right >>>>>" $outport$) |
| 238 | (terpri $outport$) |
| 239 | (return nil))) |
| 240 | (tab lmar $outport$) |
| 241 | a (cond ((and (dtpr l) |
| 242 | (atom (car l)) |
| 243 | (or (and (get (car l) 'printmacro) |
| 244 | (funcall (get (car l) 'printmacro) |
| 245 | l lmar rmar)) |
| 246 | (and (get (car l) 'printmacrochar) |
| 247 | (printmacrochar (get (car l) 'printmacrochar) |
| 248 | l lmar rmar)))) |
| 249 | (return nil)) |
| 250 | ; |
| 251 | ; -DNC - a printmacro is a lambda (l lmar rmar) |
| 252 | ; attached to the atom. If it returns nil then |
| 253 | ; we assume it did not apply and we continue. |
| 254 | ; Otherwise we assume it did the job. |
| 255 | ; |
| 256 | ((or (not (dtpr l)) |
| 257 | ; (*** at the moment we just punt hunks etc) |
| 258 | (and (atom (car l)) (atom (cdr l)))) |
| 259 | (return (printret l $outport$))) |
| 260 | ((<& (+ rmar (flatc l (charcnt $outport$))) |
| 261 | (charcnt $outport$)) |
| 262 | ; |
| 263 | ; This is just a heuristic - if print can fit it in then figure that |
| 264 | ; the printmacros won't hurt. Note that despite the pretentions there |
| 265 | ; is no guarantee that everything will fit in before rmar - for example |
| 266 | ; atoms (and now even hunks) are just blindly printed. - DNC |
| 267 | ; |
| 268 | (printaccross l lmar rmar)) |
| 269 | ((and ($patom1 lpar) |
| 270 | (atom (car l)) |
| 271 | (not (atom (cdr l))) |
| 272 | (not (atom (cddr l)))) |
| 273 | (prog (c) |
| 274 | (printret (car l) $outport$) |
| 275 | ($patom1 '" ") |
| 276 | (setq c (nwritn $outport$)) |
| 277 | a ($prd1 (cdr l) c) |
| 278 | (cond |
| 279 | ((not (atom (cdr (setq l (cdr l))))) |
| 280 | (terpr $outport$) |
| 281 | (go a))))) |
| 282 | (t |
| 283 | (prog (c) |
| 284 | (setq c (nwritn $outport$)) |
| 285 | a ($prd1 l c) |
| 286 | (cond |
| 287 | ((not (atom (setq l (cdr l)))) |
| 288 | (terpr $outport$) |
| 289 | (go a)))))) |
| 290 | b ($patom1 rpar)))) |
| 291 | |
| 292 | (def $prd1 |
| 293 | (lambda (l n) |
| 294 | (prog nil |
| 295 | ($prdf (car l) |
| 296 | n |
| 297 | (cond ((null (setq l (cdr l))) (|1+| rmar)) |
| 298 | ((atom l) (setq n nil) (plus 4 rmar (pntlen l))) |
| 299 | (t rmar))) |
| 300 | (cond |
| 301 | ((null n) ($patom1 '" . ") (return (printret l $outport$)))) |
| 302 | ; (*** setting n is pretty disgusting) |
| 303 | ; (*** the last arg to $prdf is the space needed for the suffix) |
| 304 | ; ;Note that this is still not really right - if the prefix |
| 305 | ; takes several lines one would like to use the old rmar |
| 306 | ; until the last line where the " . mumble)" goes. |
| 307 | ))) |
| 308 | |
| 309 | ; -DNC here's the printmacro for progs - it replaces some hackery that |
| 310 | ; used to be in the guts of $prdf. |
| 311 | |
| 312 | (def printprog |
| 313 | (lambda (l lmar rmar) |
| 314 | (prog (col) |
| 315 | (cond ((cdr (last l)) (return nil))) |
| 316 | (setq col (add1 lmar)) |
| 317 | (princ '|(| $outport$) |
| 318 | (princ (car l) $outport$) |
| 319 | (princ '| | $outport$) |
| 320 | (print (cadr l) $outport$) |
| 321 | (mapc '(lambda (x) |
| 322 | (cond ((atom x) |
| 323 | (tab col $outport$) |
| 324 | (print x $outport$)) |
| 325 | (t ($prdf x (+ lmar 6) rmar)))) |
| 326 | (cddr l)) |
| 327 | (princ '|)| $outport$) |
| 328 | (return t)))) |
| 329 | |
| 330 | (putprop 'prog 'printprog 'printmacro) |
| 331 | |
| 332 | ;; |
| 333 | ;; simpler version which |
| 334 | ;; should look nice for lambda's also.(inside mapcar's) -dhl |
| 335 | ;; |
| 336 | (defun print-lambda (l lmar rmar) |
| 337 | (prog (col) |
| 338 | (cond ((cdr (last l)) (return nil))) |
| 339 | (setq col (add1 lmar)) |
| 340 | (princ '|(| $outport$) |
| 341 | (princ (car l) $outport$) |
| 342 | (princ '| | $outport$) |
| 343 | (print (cadr l) $outport$) |
| 344 | (let ((c (cond ((eq (car l) 'lambda) |
| 345 | 8) |
| 346 | (t 9)))) |
| 347 | (mapc '(lambda (x) |
| 348 | ($prdf x (+ lmar c) rmar)) |
| 349 | (cddr l))) |
| 350 | (princ '|)| $outport$) |
| 351 | (terpr $outport$) |
| 352 | (tab lmar $outport$) |
| 353 | (return t))) |
| 354 | |
| 355 | (putprop 'lambda 'print-lambda 'printmacro) |
| 356 | (putprop 'nlambda 'print-lambda 'printmacro) |
| 357 | |
| 358 | ; Here's the printmacro for def. The original $prdf had some special code |
| 359 | ; for lambda and nlambda. |
| 360 | |
| 361 | (def printdef |
| 362 | (lambda (l lmar rmar) |
| 363 | (cond ((and (zerop lmar) ; only if we're really printing a defn |
| 364 | (zerop rmar) |
| 365 | (cadr l) |
| 366 | (atom (cadr l)) |
| 367 | (dtpr (caddr l)) |
| 368 | (null (cdddr l)) |
| 369 | (memq (caaddr l) '(lambda nlambda macro lexpr)) |
| 370 | (null (cdr (last (caddr l))))) |
| 371 | (princ '|(| $outport$) |
| 372 | (princ 'def $outport$) |
| 373 | (princ '| | $outport$) |
| 374 | (princ (cadr l) $outport$) |
| 375 | (terpri $outport$) |
| 376 | (princ '| (| $outport$) |
| 377 | (princ (caaddr l) $outport$) |
| 378 | (princ '| | $outport$) |
| 379 | (princ (cadaddr l) $outport$) |
| 380 | (terpri $outport$) |
| 381 | (mapc '(lambda (x) ($prdf x 4 0)) (cddaddr l)) |
| 382 | (princ '|))| $outport$) |
| 383 | t)))) |
| 384 | |
| 385 | (putprop 'def 'printdef 'printmacro) |
| 386 | |
| 387 | ; There's a version of this hacked into the printer (where it don't belong!) |
| 388 | ; Note that it must NOT apply to things like (quote a b). |
| 389 | |
| 390 | ; |
| 391 | ; adding printmacrochar so that it can be used by other read macros |
| 392 | ; which create things of the form (tag lisp-expr) like quote does, |
| 393 | ; I know this is restrictive but it is helpful in the frl source. - dhl. |
| 394 | ; |
| 395 | ; |
| 396 | |
| 397 | (def printmacrochar |
| 398 | (lambda (macrochar l lmar rmar) |
| 399 | (cond ((or (null (cdr l)) (cddr l)) nil) |
| 400 | (t (princ macrochar $outport$) |
| 401 | ($prdf (cadr l) (add1 lmar) rmar) |
| 402 | t)))) |
| 403 | |
| 404 | (putprop 'quote '|'| 'printmacrochar) |
| 405 | |
| 406 | (def printaccross |
| 407 | (lambda (l lmar rmar) |
| 408 | (prog nil |
| 409 | ; (*** this is needed to make sure the printmacros are executed) |
| 410 | (princ '|(| $outport$) |
| 411 | l: (cond ((null l)) |
| 412 | ((atom l) (princ '|. | $outport$) (princ l $outport$)) |
| 413 | (t ($prdf (car l) (nwritn $outport$) rmar) |
| 414 | (setq l (cdr l)) |
| 415 | (cond (l (princ '| | $outport$))) |
| 416 | (go l:)))))) |
| 417 | |