(defun pp fexpr (#l#)
  (prog (#buf#)
        (and (cdr nil) (print '"*** warning: cdr of nil is not nil. may cause trouble"))
        (open (#buf# 150))
        (ppform (cond ((listp (car #l#)) (eval (car #l#)))
                      ((get (car #l#) (or (cadr #l#) 'expr)))
                      ((undefp (car #l#)) (return '"*undef* "))
                      ((eval (car #l#))))
                #buf#
                (cond ((undefp '?maxlen) 80)
                      (?maxlen))
                t)
        (terpri #buf#)
        '" "))
 
 
(defun ppform (form buffer maxwidth @?)
  (prog (testbuffer ppintcp printmacro)
        (setq printmacro '(lambda (f b)
                                  (cond ((and (eq (length f) 2) (eq (car f) 'quote))
                                          (prin1 '"'" b 2 ppintcp)
                                          (prin1 (cadr f) b 6 ppintcp)
                                          t)
                                        ((and (eq (length f) 4) (eq (car f) 'breakpoint))
                                          (and @? (prin1 '@ b 2 ppintcp))
                                          (prin1 (cadr f) b 6 ppintcp)
                                          t)))
              ppintcp '(lambda x (return nil 'ppfit)))
        (status (4 quote t))
        (and (neq @? 'bp) (status (4 breakpoint t)))
        (apply1 'open (list 'testbuffer maxwidth))
        (and @? (tab 2 buffer))
        (ppform1 form)
        (status (4 quote nil) (4 breakpoint nil))))
 
 
(defun ppform1 (form)
  (cond ((atom form) (prin1 form buffer 6))
        ((and (neq (car form) 'cond) (ppfit form)))
        ((ppspecial form))
        ((prog (carform tab)
               (setq carform (uncons form form))
               (prin1 '"(" buffer 2)
               (cond ((atom carform)
                       (prin1 carform buffer 6)
                       (prin1 '" " buffer 2)
                       (setq tab (add1 (plen buffer)))
                       (cond ((listp form) (ppform1 (uncons form form)))
                             (form (prin1 '"." buffer 2) (prin1 form buffer 4) (setq form nil))
                             (t (skip -1 buffer))))
                     (t (setq tab (plus 2 (plen buffer))) (ppform1 carform)))
               (mapc '(lambda (carform) (terpri buffer) (tab tab buffer) (ppform1 carform)) form)
               (and (cdr (last form)) (prin1 '"." buffer) (prin1 (cdr (last form)) buffer 4))
               (prin1 '")" buffer 2)))))
 
 
(defun ppfit (form)
  (tab 1 testbuffer)
  (cond ((greaterp maxwidth
                   (plus (plen buffer) (progn (prin1 form testbuffer 6 ppintcp) (plen testbuffer))))
          (prin1 (car testbuffer) buffer 2)
          t)))
 
 
(defun ppspecial (form)
  (cond ((and (atom (car form)) (not (numberp (car form))))
          (apply1 (get (car form) 'ppspecial '(return nil 'ppspecial)) form)
          t)))
 
 
(defun ppprog (form)
  (prin1 '"(" buffer 2)
  (prin1 (uncons form form) buffer 6)
  (skip 1 buffer)
  (prog (tab vars)
        (setq tab (add1 (plen buffer)))
        (cond ((ppfit (car form)))
              (t (setq vars (car form))
                 (prin1 '"(" buffer 2)
                 (prin1 (car vars) buffer 6)
                 (mapc '(lambda (carform)
                                (skip 1 buffer)
                                (cond ((ppfit carform))
                                      (t (terpri buffer)
                                         (tab tab buffer)
                                         (cond ((ppfit carform))
                                               (t (ppform1 carform))))))
                       (cdr vars))
                 (prin1 '")" buffer 2)))
        (mapc '(lambda (form)
                       (terpri buffer)
                       (tab tab buffer)
                       (cond ((atom form) (skip -2 buffer) (prin1 form buffer 6))
                             ((ppform1 form))))
              (cdr form))
        (prin1 '")" buffer 2)))
 
 
(defun ppsetq (form)
  (prin1 '"(" buffer 2)
  (prin1 (car form) buffer 6)
  (prin1 '" " buffer 2)
  (prog (tab sw)
        (setq tab (add1 (plen buffer)) sw t form (cdr form))
        (repeat '(progn (or sw (terpri buffer) (tab tab buffer))
                        (ppform1 (car form))
                        (skip 1 buffer)
                        (ppform1 (cadr form))
                        (setq form (cddr form) sw nil))
                (shift (length form) -1)))
  (prin1 '")" buffer 2))
 
 
(defun ppquote (form)
  (cond ((eq (length form) 2) (prin1 '"'" buffer 2) (ppform1 (cadr form)))
        ((return nil 'ppspecial))))
 
 
(defun ppbreakpoint (form)
  (cond ((and (eq (length form) 4) (status (4 breakpoint)))
          (and @? (prin1 '@ buffer 2))
          (ppform1 (cadr form)))
        ((return nil 'ppspecial))))
 
 
(defprop prog ppspecial ppprog)
 
 
(defprop (setq set) ppspecial ppsetq)
 
 
(defprop quote ppspecial ppquote)
 
 
(defprop breakpoint ppspecial ppbreakpoint)
 
 
(defun printmacro (l)
  (cond ((undefp 'printmacro) (status (4 quote nil) (4 breakpoint nil)) nil)
        ((apply1 printmacro (car l) (cdr l)))))
 
 
(defprop 'breakpoint pmacro printmacro)
