module/slib/ppfile.scm

   1 ;;;; "ppfile.scm".  Pretty print a Scheme file.
   2 ;Copyright (C) 1993, 1994 Aubrey Jaffer
   3 ;
   4 ;Permission to copy this software, to redistribute it, and to use it
   5 ;for any purpose is granted, subject to the following restrictions and
   6 ;understandings.
   7 ;
   8 ;1.  Any copy made of this software must include this copyright notice
   9 ;in full.
  10 ;
  11 ;2.  I have made no warrantee or representation that the operation of
  12 ;this software will be error-free, and I am under no obligation to
  13 ;provide any services, by way of maintenance, update, or otherwise.
  14 ;
  15 ;3.  In conjunction with products arising from the use of this
  16 ;material, there shall be no use of my name in any advertising,
  17 ;promotional, or sales literature without prior written consent in
  18 ;each case.
  19
  20 (require 'pretty-print)
  21
  22 (define (pprint-filter-file inport filter . optarg)
  23   ((lambda (fun)
  24      (if (input-port? inport)
  25          (fun inport)
  26          (call-with-input-file inport fun)))
  27    (lambda (port)
  28      ((lambda (fun)
  29         (let ((outport
  30                (if (null? optarg) (current-output-port) (car optarg))))
  31           (if (output-port? outport)
  32               (fun outport)
  33               (call-with-output-file outport fun))))
  34       (lambda (export)
  35         (let ((old-load-pathname *load-pathname*))
  36           (set! *load-pathname* inport)
  37           (letrec ((lp (lambda (c)
  38                          (cond ((eof-object? c))
  39                                ((char-whitespace? c)
  40                                 (display (read-char port) export)
  41                                 (lp (peek-char port)))
  42                                ((char=? #\; c)
  43                                 (cmt c))
  44                                (else (sx)))))
  45                    (cmt (lambda (c)
  46                           (cond ((eof-object? c))
  47                                 ((char=? #\newline c)
  48                                  (display (read-char port) export)
  49                                  (lp (peek-char port)))
  50                                 (else
  51                                  (display (read-char port) export)
  52                                  (cmt (peek-char port))))))
  53                    (sx (lambda ()
  54                          (let ((o (read port)))
  55                            (cond ((eof-object? o))
  56                                  (else
  57                                   (pretty-print (filter o) export)
  58                                   ;; pretty-print seems to have extra newline
  59                                   (let ((c (peek-char port)))
  60                                     (cond ((eqv? #\newline c)
  61                                            (read-char port)
  62                                            (set! c (peek-char port))))
  63                                     (lp c))))))))
  64             (lp (peek-char port)))
  65           (set! *load-pathname* old-load-pathname)))))))
  66
  67 (define (pprint-file ifile . optarg)
  68   (pprint-filter-file ifile
  69                       (lambda (x) x)
  70                       (if (null? optarg) (current-output-port) (car optarg))))