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