Return to pp.l CVS log

Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / lisplib

Annotation of 43BSDReno/pgrm/lisp/lisplib/pp.l, revision 1.1

1.1     ! root        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: 
        !           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: 
        !           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: 

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.