1 ; FP interpreter/compiler 2 ; Copyright (c) 1982 Scott B. Baden 3 ; Berkeley, California 4 ; 5 ; Copyright (c) 1982 Regents of the University of California. 6 ; All rights reserved. The Berkeley software License Agreement 7 ; specifies the terms and conditions for redistribution. 8 ; 9 (setq SCCS-fpPP.l "@(#)fpPP.l 5.1 (Berkeley) 05/31/85") 10 11 ;; pretty printer for fp -- snarfed from FRANZ LISP 12 13 (include specials.l) 14 15 (declare (special fpPParm1 fpPParm2 lAngle rAngle)) 16 17 ; printRet is like print yet it returns the value printed, 18 ; this is used by fpPP. 19 20 (def printRet 21 (macro ($l$) 22 `(progn 23 (let ((z ,@(cdr $l$))) 24 (cond ((null z) (patom "<>")) 25 (t 26 (print ,@(cdr $l$)))))))) 27 28 29 (def fpPP 30 (lambda (x) 31 (terpri) 32 (prDF x 0 0) 33 (terpri))) 34 35 36 (setq fpPParm1 50 fpPParm2 100) 37 38 ; -DNC These "prettyprinter parameters" are used to decide when we should 39 ; quit printing down the right margin and move back to the left - 40 ; Do it when the leftmargin > fpPParm1 and there are more than fpPParm2 41 ; more chars to print in the expression 42 43 44 45 (declare (special rmar)) 46 47 (def prDF 48 (lambda (l lmar rmar) 49 (prog nil 50 ; 51 ; - DNC - Here we try to fix the tendency to print a 52 ; thin column down the right margin by allowing it 53 ; to move back to the left if necessary. 54 ; 55 (cond ((and (>& lmar fpPParm1) (>& (flatc l (1+ fpPParm2)) fpPParm2)) 56 (terpri) 57 (patom "; <<<<< start back on the left <<<<<") 58 (prDF l 5 0) 59 (terpri) 60 (patom "; >>>>> continue on the right >>>>>") 61 (terpri) 62 (return nil))) 63 (tab lmar) 64 a (cond 65 ((or (not (dtpr l)) 66 ; (*** at the moment we just punt hunks etc) 67 ;(and (atom (car l)) (atom (cdr l))) 68 ) 69 (return (printRet l))) 70 ((<& (+ rmar (flatc l (charcnt poport))) 71 (charcnt poport)) 72 ; 73 ; This is just a heuristic - if print can fit it in then figure that 74 ; the printmacros won't hurt. Note that despite the pretentions there 75 ; is no guarantee that everything will fit in before rmar - for example 76 ; atoms (and now even hunks) are just blindly printed. - DNC 77 ; 78 (printAccross l lmar rmar)) 79 ((and ($patom1 lAngle) 80 (atom (car l)) 81 (not (atom (cdr l))) 82 (not (atom (cddr l)))) 83 (prog (c) 84 (printRet (car l)) 85 ($patom1 '" ") 86 (setq c (nwritn)) 87 a (prD1 (cdr l) c) 88 (cond 89 ((not (atom (cdr (setq l (cdr l))))) 90 (terpri) 91 (go a))))) 92 (t 93 (prog (c) 94 (setq c (nwritn)) 95 a (prD1 l c) 96 (cond 97 ((not (atom (setq l (cdr l)))) 98 (terpri) 99 (go a)))))) 100 b ($patom1 rAngle)))) 101 102 103 (def prD1 104 (lambda (l n) 105 (prog nil 106 (prDF (car l) 107 n 108 (cond ((null (setq l (cdr l))) (|1+| rmar)) 109 ((atom l) (setq n nil) (plus 4 rmar (pntlen l))) 110 (t rmar))) 111 112 ; The last arg to prDF is the space needed for the suffix 113 ; Note that this is still not really right - if the prefix 114 ; takes several lines one would like to use the old rmar 115 ; until the last line where the " . mumble" goes. 116 ))) 117 118 119 (def printAccross 120 (lambda (l lmar rmar) 121 (prog nil 122 ; this is needed to make sure the printmacros are executed 123 (princ '|<|) 124 l: (cond ((null l)) 125 (t (prDF (car l) (nwritn) rmar) 126 (setq l (cdr l)) 127 (cond (l (princ '| |))) 128 (go l:)))))) 129