home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e070 / 4.ddi / LISPLIB / PPRINT.LSP < prev    next >
Encoding:
Text File  |  1984-11-06  |  8.5 KB  |  310 lines
  1. ;;; Copyright (C) 1984 by Gold Hill Computers
  2.  
  3. ;; This file contains the GCLisp Pretty Printer.  
  4.  
  5. (DEFVAR *PPRINT-WINDOW-WIDTH* 79)
  6. (DEFVAR *PPRINT-LEFT-MARGIN*  0)
  7.  
  8.  
  9. (DEFUN PPRINT (OBJECT &OPTIONAL STREAM)
  10.   (LET ((*PPRINT-QUOTE* NIL)
  11.         (PPRINT-COLUMN 0)
  12.     (*STANDARD-OUTPUT* 
  13.          (COND ((NULL STREAM)
  14.             *STANDARD-OUTPUT*)
  15.            ((EQ STREAM T)
  16.             *TERMINAL-IO*)
  17.            (T  STREAM)))
  18.     )
  19.     (PPRINT-NEWLINE 0)
  20.     (I-PPRINT OBJECT )
  21.     (VALUES NIL)
  22.  ))
  23.  
  24.  
  25. (DEFUN I-PPRINT (OBJECT)
  26.   (LET ((CURRENT-MARGIN (GET-COLUMN)))
  27.     (COND ((SYMBOLP OBJECT) 
  28.        (PPATOM OBJECT CURRENT-MARGIN))
  29.       ((NUMBERP OBJECT) 
  30.        (PPNUMBER OBJECT CURRENT-MARGIN))
  31.       ((ARRAYP  OBJECT) 
  32.        (PPARRAY OBJECT CURRENT-MARGIN))
  33.       ((LISTP   OBJECT) 
  34.        (PPLIST  OBJECT CURRENT-MARGIN))
  35.       (T    
  36.        (PRIN1 OBJECT ))
  37.       )))
  38.  
  39.  
  40. (DEFUN PPLIST (OBJECT CURRENT-MARGIN)
  41.   (LET ((PPRINT-PROP NIL)
  42.     (FIRST (FIRST OBJECT))
  43.     (REST  (REST OBJECT)))
  44.     (COND ((AND (SYMBOLP FIRST) 
  45.         (GET FIRST 'PPRINT) )
  46.        (SETQ PPRINT-PROP (GET FIRST 'PPRINT))
  47.        (IF (SYMBOLP PPRINT-PROP) 
  48.            (APPLY PPRINT-PROP (LIST OBJECT))
  49.            (I-PPLIST OBJECT PPRINT-PROP CURRENT-MARGIN)))
  50.       ( T
  51.              (PPRINT-WRITE-CHAR #\( )
  52.          (WHEN OBJECT 
  53.            (I-PPRINT (CAR OBJECT))
  54.            (I-PPLIST1 REST))
  55.          (PPRINT-WRITE-CHAR #\) ))
  56.       )))
  57.  
  58. (DEFUN I-PPLIST1 (OBJECT)
  59.   (WHEN (UPDATE-LINE-COUNT (IF (LISTP OBJECT) (FIRST OBJECT) OBJECT))
  60.        (PPRINT-NEWLINE CURRENT-MARGIN))
  61.   (WHEN OBJECT (PPRINT-WRITE-CHAR #\SPACE))
  62.   (COND    ((TYPEP OBJECT 'CONS)
  63.      (I-PPRINT (FIRST OBJECT))
  64.          (I-PPLIST1 (REST OBJECT))
  65.       )
  66.     (OBJECT
  67.      (PPRINT-WRITE-CHAR #\.)
  68.      (PPRINT-WRITE-CHAR #\SPACE)
  69.      (I-PPRINT OBJECT))
  70.     ))
  71.    
  72.  
  73. ;; The real work horse, used to pprint all of the 
  74. ;; special forms which have templates.
  75.  
  76. (DEFUN I-PPLIST (OBJECT TEMPLATE CURRENT-MARGIN)
  77.   (PPRINT-WRITE-CHAR #\()
  78.   (PPRINT-PRINC (FIRST OBJECT))
  79.   (PPRINT-WRITE-CHAR #\SPACE)
  80.   (DO* ((TEMPLATE TEMPLATE (REST TEMPLATE))
  81.     (REST   (REST OBJECT)   (REST REST))
  82.     (FORM   (FIRST REST)    (FIRST REST))
  83.     (STRUCT (CAAR TEMPLATE) (CAAR TEMPLATE))
  84.     (INDENT (CADAR TEMPLATE) (CADAR TEMPLATE))
  85.     (NEW-LINEP (FIRST (CDDAR TEMPLATE))
  86.      (FIRST (CDDAR TEMPLATE))))
  87.        ((NULL TEMPLATE) )
  88.     (UNLESS (NULL (FIRST TEMPLATE))
  89.       (WHEN NEW-LINEP 
  90.     (PPRINT-NEWLINE (+ CURRENT-MARGIN INDENT)))
  91.  
  92.           (CASE STRUCT
  93.         (NAME 
  94.              (I-PPRINT FORM)
  95.              (PPRINT-WRITE-CHAR #\SPACE))
  96.         (LAMBDA-LIST
  97.              (PPLIST FORM (+ CURRENT-MARGIN 8)))
  98.         (COND-BODY
  99.              (DOLIST (EXPRESION REST)
  100.             (PPRINT-WRITE-CHAR #\()
  101.             (I-PPRINT (FIRST EXPRESION))
  102.                 (PPRINT-NEWLINE (+ CURRENT-MARGIN (+ INDENT 1)))
  103.             (FORM2-PPRINT (CDR EXPRESION) 
  104.                           (+ INDENT 1)
  105.                       CURRENT-MARGIN)
  106.             (PPRINT-WRITE-CHAR #\))
  107.             (PPRINT-NEWLINE (+ CURRENT-MARGIN INDENT))
  108.             ))
  109.         (ARG-PAIRS
  110.              (DO ((ARG1 (FIRST REST)  (FIRST REST))
  111.                           (ARG2 (CADR REST)   (CADR REST))
  112.                           (REST (CDDR REST)   (CDDR REST))
  113.               (TERMINATOR REST    (CDDR TERMINATOR)))
  114.                          ((NULL TERMINATOR))
  115.                        (I-PPRINT ARG1)
  116.                        (PPRINT-WRITE-CHAR #\SPACE)
  117.                (I-PPRINT ARG2)
  118.                (WHEN REST (PPRINT-NEWLINE (+ CURRENT-MARGIN INDENT)))
  119.               ))
  120.         (CONDITION
  121.              (I-PPRINT FORM))
  122.                 (COND-PAIR
  123.              (FORM1-PPRINT FORM INDENT CURRENT-MARGIN))
  124.                 (PROG-BODY-REST
  125.              (FORM2-PPRINT REST INDENT CURRENT-MARGIN))
  126.                 (PROG-BODY
  127.              (PPRINT-NEWLINE (+ CURRENT-MARGIN (1- INDENT)))
  128.                      (FORM1-PPRINT FORM INDENT CURRENT-MARGIN))
  129.               (DO-BINDINGS
  130.              (FORM1-PPRINT FORM INDENT CURRENT-MARGIN))
  131.             (OTHERWISE (PRINT FORM))
  132.     )))
  133.      (PPRINT-WRITE-CHAR #\))
  134.  )
  135.  
  136. (DEFUN FORM1-PPRINT (FORM LEVEL CURRENT-MARGIN)
  137.     (PPRINT-WRITE-CHAR #\()
  138.     (FORM2-PPRINT FORM LEVEL CURRENT-MARGIN)
  139.     (PPRINT-WRITE-CHAR #\))
  140.   )
  141.  
  142. (DEFUN FORM2-PPRINT (FORM LEVEL CURRENT-MARGIN)
  143.   (LET ((FIRST NIL)
  144.         (VERTICAL (AND (> 2 (LENGTH FORM))(UPDATE-LINE-COUNT FORM))))
  145.     (DOLIST (THING FORM)
  146.       (WHEN (OR VERTICAL FIRST) 
  147.          (WHEN FIRST (PPRINT-NEWLINE (+ CURRENT-MARGIN LEVEL))))
  148.       (SETQ FIRST T)
  149.       (I-PPRINT THING ))
  150.    ))
  151.  
  152. (DEFUN PPNUMBER (OBJECT CURRENT-MARGIN)
  153.   (WHEN (UPDATE-LINE-COUNT OBJECT)
  154.          (PPRINT-NEWLINE (+ CURRENT-MARGIN 2)))
  155.   (SETF PPRINT-COLUMN (+ PPRINT-COLUMN (FLATSIZE OBJECT)))
  156.   (PRIN1 OBJECT )
  157.  )
  158.  
  159. ;; For PPRINTing atoms
  160. ;;
  161. (DEFUN PPATOM (OBJECT CURRENT-MARGIN)
  162.   (WHEN (UPDATE-LINE-COUNT OBJECT)
  163.          (PPRINT-NEWLINE (+ CURRENT-MARGIN 2)))
  164.   (SETF PPRINT-COLUMN (+ PPRINT-COLUMN (FLATSIZE OBJECT)))
  165.   (PRIN1 OBJECT)
  166.  )
  167.  
  168. ;; For PPRINTing arrays
  169. ;;
  170. (DEFUN PPARRAY (OBJECT CURRENT-MARGIN)
  171.   (WHEN (UPDATE-LINE-COUNT OBJECT)
  172.              (PPRINT-NEWLINE))
  173.   (SETF PPRINT-COLUMN (+ PPRINT-COLUMN (FLATSIZE OBJECT)))
  174.   (PRIN1 OBJECT)
  175. )
  176.  
  177. (DEFUN PPRINT-NEWLINE (&OPTIONAL (PPRINT-LEFT-MARGIN (GET-COLUMN)))
  178.   (PPRINT-WRITE-CHAR #\NEWLINE)
  179.   (DOTIMES (I PPRINT-LEFT-MARGIN) (PPRINT-WRITE-CHAR #\SPACE))
  180.  )
  181.  
  182. (DEFUN PPRINT-PRINC (OBJECT)
  183.  (PRINC OBJECT)
  184.  (SETF PPRINT-COLUMN (+ PPRINT-COLUMN (FLATSIZE OBJECT))))
  185.  
  186. (DEFUN PPRINT-WRITE-CHAR (CHAR)
  187.   (IF (EQ CHAR #\NEWLINE)
  188.      (SETF PPRINT-COLUMN 0)
  189.      (INCF PPRINT-COLUMN))
  190.   (WRITE-CHAR CHAR)
  191.   )
  192.     
  193.  
  194.  
  195. ;; A test to see if something is going to fit on a line
  196. ;;
  197. (DEFUN UPDATE-LINE-COUNT (OBJECT)
  198.   (IF OBJECT (>= (+ (GET-COLUMN) (FLATSIZE OBJECT))
  199.                   *PPRINT-WINDOW-WIDTH*)
  200.       NIL))
  201.  
  202.  
  203. ;; simply return the pretty printer curent column
  204. ;;
  205. (DEFUN GET-COLUMN ()
  206.   PPRINT-COLUMN)
  207.  
  208. ;; The following are the standard GCLisp templates used for
  209. ;; pretty printing all special forms and macros.  
  210. ;;
  211.  
  212.  
  213. (PUTPROP 'AND '((PROG-BODY-REST 5)) 'PPRINT)
  214.  
  215. (PUTPROP 'BLOCK '((NAME 0) (PROG-BODY-REST 2 T)) 'PPRINT)
  216.  
  217. (PUTPROP 'CASE '((CONDITION 5)(COND-BODY 6 T)) 'PPRINT)
  218.  
  219. (PUTPROP 'CATCH '((NAME 0) (PROG-BODY-REST 2)) 'PPRINT)
  220.  
  221. (PUTPROP 'COND '((COND-BODY 6)) 'PPRINT)
  222.  
  223. (PUTPROP 'DEFUN '((NAME 0)(LAMBDA-LIST 10)(PROG-BODY-REST 2 T)) 'PPRINT)
  224.  
  225. (PUTPROP 'DEFMACRO '((NAME 0) (NAME 0) (PROG-BODY-REST 2 T)) 'PPRINT)
  226.  
  227. (PUTPROP 'DO '((DO-BINDINGS 5)(PROG-BODY 5)(PROG-BODY-REST 2 T)) 'PPRINT)
  228.  
  229. (PUTPROP 'DO* '((DO-BINDINGS 6)(PROG-BODY 6)(PROG-BODY-REST 2 T)) 'PPRINT)
  230.  
  231. (PUTPROP 'DOLIST '((CONDITION 6)(PROG-BODY-REST 2 T)) 'PPRINT)
  232.  
  233. (PUTPROP 'DOTIMES '((CONDITION 6)(PROG-BODY-REST 2 T)) 'PPRINT)
  234.  
  235. (PUTPROP 'IF '((CONDITION 4)(PROG-BODY-REST 4 T)) 'PPRINT)
  236.  
  237. (PUTPROP 'IFN '((CONDITION 5)(PROG-BODY-REST 5 T)) 'PPRINT)
  238.  
  239. (PUTPROP 'LAMBDA '((LAMBDA-LIST 6)(PROG-BODY-REST 2 T)) 'PPRINT)
  240.  
  241. (PUTPROP 'LET '((COND-PAIR 6)(PROG-BODY-REST 2 T)) 'PPRINT)
  242.  
  243. (PUTPROP 'LET* '((COND-PAIR 7)(PROG-BODY-REST 2 T)) 'PPRINT)
  244.  
  245. (PUTPROP 'LOOP '((PROG-BODY-REST 2 T)) 'PPRINT)
  246.  
  247. (PUTPROP 'MACRO '((NAME 0)(LAMBDA-LIST 10)(PROG-BODY-REST 2 T)) 'PPRINT)
  248.  
  249. (PUTPROP 'MAPCAR '((NAME 0)(PROG-BODY-REST 8)) 'PPRINT)
  250.  
  251. (PUTPROP 'MAPC '((NAME 0)(PROG-BODY-REST 6)) 'PPRINT)
  252.  
  253. (PUTPROP 'MAPCAN '((NAME 0)(PROG-BODY-REST 8)) 'PPRINT)
  254.  
  255. (PUTPROP 'MAPCON '((NAME 0)(PROG-BODY-REST 8)) 'PPRINT)
  256.  
  257. (PUTPROP 'MAPL '((NAME 0)(PROG-BODY-REST 6)) 'PPRINT)
  258.  
  259. (PUTPROP 'MAPLIST '((NAME 0)(PROG-BODY-REST 9)) 'PPRINT)
  260.  
  261. (PUTPROP 'MULTIPLE-VALUE-SETQ '((PROG-BODY-REST 2 T)) 'PPRINT)
  262.  
  263. (PUTPROP 'MULTIPLE-VALUE-BIND '((PROG-BODY-REST 2 T)) 'PPRINT)
  264.  
  265. (PUTPROP 'MULTIPLE-VALUE-LIST '((PROG-BODY-REST 2 T)) 'PPRINT)
  266.  
  267. (PUTPROP 'PROG '((COND-PAIR 7)(PROG-BODY-REST 2 T)) 'PPRINT)
  268.  
  269. (PUTPROP 'PROG* '((COND-PAIR 8)(PROG-BODY-REST 2 T)) 'PPRINT)
  270.  
  271. (PUTPROP 'PROGV '((COND-PAIR 8)(PROG-BODY-REST 2 T)) 'PPRINT)
  272.  
  273. (PUTPROP 'PROG1 '((PROG-BODY-REST 2 T)) 'PPRINT)
  274.  
  275. (PUTPROP 'PROG2 '((PROG-BODY-REST 2 T)) 'PPRINT)
  276.  
  277. (PUTPROP 'PROGN '((PROG-BODY-REST 2 T)) 'PPRINT)
  278.  
  279. (PUTPROP 'PSETF '((ARG-PAIRS 7)) 'PPRINT)
  280.  
  281. (PUTPROP 'PSETQ '((ARG-PAIRS 7)) 'PPRINT)
  282.  
  283. (PUTPROP 'OR '((PROG-BODY-REST 4)) 'PPRINT)
  284.  
  285. (PUTPROP 'QUOTE 'PPRINT-QUOTE 'PPRINT)
  286.  
  287. (DEFUN PPRINT-QUOTE (OBJECT)
  288.   (LET ((CURRENT-MARGIN (GET-COLUMN)))
  289.    (COND
  290.      (*PPRINT-QUOTE* 
  291.       (I-PPRINT OBJECT))
  292.      (T
  293.       (WHEN (>= (GET-COLUMN) (- *PPRINT-WINDOW-WIDTH* 5))
  294.         (PPRINT-NEWLINE (+ CURRENT-MARGIN 2)))
  295.       (PPRINT-WRITE-CHAR #\')
  296.       (I-PPRINT (CADR OBJECT)))
  297.     )))
  298.  
  299. (PUTPROP 'SETF   '((ARG-PAIRS 6)) 'PPRINT)
  300.  
  301. (PUTPROP 'SETQ   '((ARG-PAIRS 6)) 'PPRINT)
  302.  
  303. (PUTPROP 'UNLESS '((CONDITION 7)(PROG-BODY-REST 2 T)) 'PPRINT)
  304.  
  305. (PUTPROP 'UNWIND-PROTECT '((PROG-BODY 2)(PROG-BODY-REST 2 T)) 'PPRINT)
  306.  
  307. (PUTPROP 'WHEN '((CONDITION 7)(PROG-BODY-REST 2 T)) 'PPRINT)
  308.  
  309. ;; end of supported code.
  310.