home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / LISP / PDLISP.ZIP / FMTIO.L < prev    next >
Encoding:
Text File  |  1986-05-07  |  3.6 KB  |  114 lines
  1. ; fmtio.l - Copyright (c) 1984 by David Morein.
  2. ; this file contains miscellaneous formatted i/o routines.
  3. ;
  4. ; note - this is an initialization file, see the manual for more info.
  5. ;
  6. ; global functions:
  7. ;
  8. (global 'pp 'ppdef)
  9. ;
  10. ; load in the pretty-printer:
  11. ;
  12. ; public function pp:
  13. ;
  14. (defun pp (x)
  15.     (progn
  16.     (*pp1 x 0 t)
  17.     (terpri)
  18.     t))
  19. ;
  20. ; private function *pp1:
  21. ;
  22. (defun *pp1 (exp column newline &optional tblank
  23.          &aux new1 new2 new3 entrycol)
  24.         (progn
  25.         (cond (newline (progn (terpri) (space_to_col column))))
  26.         (setq entrycol column)          ;save entry value column.
  27.         (cond
  28.         ((atom exp)        ;exp is atomic
  29.             (prin1 exp)
  30.             (if tblank (princ " "))
  31.             (setq column (+ column (length exp))))
  32.  
  33.         ((not (listp (cdr exp)))    ;exp is a dotted pair
  34.             (princ "(")
  35.             (prin1 (car exp))
  36.             (princ " . ")
  37.             (prin1 (cdr exp))
  38.             (princ ")")
  39.             (if tblank (princ " "))
  40.             (setq column (+ column (flatsize exp))))
  41.  
  42.         (t                    ;exp is a list
  43.         (cond
  44.           ((eq (car exp) 'backquote)
  45.               (princ "`")  (*pp1 (cadr exp) column nil tblank))
  46.           ((eq (car exp) 'comma)    
  47.               (princ ",")  (*pp1 (cadr exp) column nil tblank))
  48.           ((eq (car exp) 'comma-at)    
  49.               (princ ",@") (*pp1 (cadr exp) column nil tblank))
  50.           ((eq (car exp) 'quote)
  51.               (princ "'")  (*pp1 (cadr exp) column nil tblank))
  52.           (t
  53.                 (setq new1            ;set new1 if (car exp)
  54.                     (cond            ; is a special form.
  55.                         ((consp exp) (isspecial (car exp)))
  56.                         (t  nil)))
  57.  
  58.                 (setq new2                      ;set new2 if
  59.                     (>=                         ; exp won't fit on
  60.                         (+ 8 (flatsize exp))    ; a single line.
  61.                         (- conwidth column)))   ;
  62.  
  63.                 (princ "(")
  64.                 (setq column (+ column 1))
  65.                 (setq column (*pp1 (car exp) column nil t))
  66.                 (cond
  67.                     ((cdr exp)
  68.                         (setq new3 (isspecial (cadr exp)))
  69.                         (setq column (+ column 1))      ;increment column
  70.                         (setq column                    ;print 2nd element
  71.                             (*pp1 (cadr exp) column (or new1 new2 new3) t))
  72. ;
  73. ; the following call to MAPCAR should be replaced with a DO.
  74. ;
  75.                         (mapcar                         ;and then rest of list.
  76.                            '(lambda (exp) (*pp1 exp (+ entrycol 2) new2 t))
  77.                             (cddr exp))))
  78.                 (princ ")")                             ;print right paren.
  79.         (if tblank (princ " "))
  80.                 (setq column (+ column 1)))))))        ;increment column.
  81.             column)                    ;return current column.
  82. ;
  83. ; isspecial - recognizes special forms:
  84. ;
  85. (defun isspecial (exp)
  86.     (cond
  87.         ((eql exp 'prog)  t)
  88.         ((eql exp 'progn) t)
  89.         ((eql exp 'cond)  t)
  90.         (t              nil)))
  91. ;
  92. ;
  93. ; space_to_col - forces the cursor to an x-position on the current line,
  94. ;                filling with spaces as necessary.
  95. ;
  96. (defun space_to_col (x)
  97.     (prog ()
  98.     (loop
  99.             (cond 
  100.                 ((< (+ (status x_position) 8) x) (princ "        "))
  101.                 ((< (+ (status x_position) 4) x) (princ "    "))
  102.                 ((< (status x_position) x) (princ " "))
  103.                 (t  (return t))))))
  104. ;
  105. ; ppdef - pretty-prints the function definition cell of an atom:
  106. ;
  107. (defun ppdef (x) 
  108.     (cond 
  109.     ((fboundp x) (pp (getd x)))
  110.     (t  (err "***> PPDEF: arg not bound as a function."))))
  111. ;
  112. ;
  113. ;end of file
  114.