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