home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / o / ops5.zip / PP.OPS < prev    next >
Lisp/Scheme  |  1992-05-31  |  2KB  |  54 lines
  1. ; Production pretty printer.
  2. ; The program takes productions in any lousy
  3. ; format and attempts to print them properly.
  4.  
  5. (declare (special pcount oport cinp))
  6.  
  7. (defun pp (ifile ofile)
  8.        (prog (iport)
  9.          (setq iport (infile ifile))
  10.          (setq oport (outfile ofile))
  11.          (setq pcount 1)
  12.          (setq cinp (read iport))
  13.          (while cinp
  14.             (cond ((atom cinp) (print cinp oport) (terpri oport))
  15.               ((not (equal (car cinp) 'p)) (print cinp oport)
  16.                  (terpri oport))
  17.               (t (print-prod) (terpri oport)))
  18.             (setq cinp (read iport)))
  19.          (terpri oport)))
  20.  
  21.  
  22. (defun print-prod ()
  23.        (prog nil
  24.          (princ "(p " oport)
  25.          (print (cadr cinp) oport) (terpri oport)
  26.          (setq cinp (cddr cinp))
  27.          (while cinp
  28.             (cond ((and (atom (car cinp)) (equal (car cinp) '-->))
  29.                (princ "  -->" oport) (terpri oport)
  30.                (setq cinp (cdr cinp)))
  31.               ((and (atom (car cinp)) (equal (car cinp) '{))
  32.                (princ "    " oport)
  33.                (print-ce-with-var) (terpri oport))
  34.               ((and (atom (car cinp)) (equal (car cinp) '-))
  35.                (princ "  - " oport) 
  36.                (print (cadr cinp) oport) (terpri oport)
  37.                (setq cinp (cddr cinp)))
  38.               (t (princ "    " oport)
  39.                  (print (car cinp) oport) (terpri oport)
  40.                  (setq cinp (cdr cinp)))))
  41.          (setq pcount (1+ pcount))
  42.          (princ ")" oport) (terpri oport)))
  43.  
  44.  
  45. (defun print-ce-with-var ()
  46.     (prog nil
  47.       (while (not (equal (car cinp) '}))
  48.          (print (car cinp) oport) (princ " " oport)
  49.          (setq cinp (cdr cinp)))
  50.       (print (car cinp) oport)
  51.       (setq cinp (cdr cinp))))
  52.  
  53.                              
  54.