home *** CD-ROM | disk | FTP | other *** search
/ RISC DISC 2 / RISC_DISC_2.iso / pd_share / program / language / scm / !Scm / slib / ppfile < prev    next >
Encoding:
Text File  |  1994-02-17  |  1.4 KB  |  52 lines
  1. ;;;; "ppfile.scm".  Pretty print a Scheme file.
  2.  
  3. (require 'pretty-print)
  4.  
  5. (define (pprint-filter-file inport filter outport)
  6.   ((lambda (fun)
  7.      (if (input-port? inport)
  8.      (fun inport)
  9.      (call-with-input-file inport fun)))
  10.    (lambda (port)
  11.      ((lambda (fun)
  12.     (if (output-port? outport)
  13.         (fun outport)
  14.         (call-with-output-file outport fun)))
  15.       (lambda (export)
  16.     (let ((old-load-pathname *load-pathname*))
  17.       (set! *load-pathname* inport)
  18.       (letrec ((lp (lambda (c)
  19.              (cond ((eof-object? c))
  20.                    ((char-whitespace? c)
  21.                 (display (read-char port) export)
  22.                 (lp (peek-char port)))
  23.                    ((char=? #\; c)
  24.                 (cmt c))
  25.                    (else (sx)))))
  26.            (cmt (lambda (c)
  27.               (cond ((eof-object? c))
  28.                 ((char=? #\newline c)
  29.                  (display (read-char port) export)
  30.                  (lp (peek-char port)))
  31.                 (else
  32.                  (display (read-char port) export)
  33.                  (cmt (peek-char port))))))
  34.            (sx (lambda ()
  35.              (let ((o (read port)))
  36.                (cond ((eof-object? o))
  37.                  (else
  38.                   (pretty-print (filter o) export)
  39.                   ;; pretty-print seems to have extra newline
  40.                   (let ((c (peek-char port)))
  41.                     (cond ((eqv? #\newline c)
  42.                        (read-char port)
  43.                        (set! c (peek-char port))))
  44.                     (lp c))))))))
  45.         (lp (peek-char port)))
  46.       (set! *load-pathname* old-load-pathname)))))))
  47.  
  48. (define (pprint-file ifile . optarg)
  49.   (pprint-filter-file ifile
  50.               (lambda (x) x)
  51.               (if (null? optarg) (current-output-port) (car optarg))))
  52.