punify

[Thien-Thi Nguyen]

the TODO list is gone, all items processed.  the one item dropped was
"identifier punification", which is out of the scope of this program.
in fact, some new anti-punification code is in.  (gasp, horror! :-)

thi

_________________________________________
#!/bin/sh
exec ${GUILE-guile} -e '(scripts punify)' -s $0 "$@" # -*- scheme -*-
!#
;;; punify --- Display Scheme code w/o unnecessary comments / whitespace

;;      Copyright (C) 2001,2003,2004 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;; Boston, MA 02111-1307 USA
;;
;; As a special exception, the Free Software Foundation gives permission
;; for additional uses of the text contained in its release of GUILE.
;;
;; The exception is that, if you link the GUILE library with other files
;; to produce an executable, this does not by itself cause the
;; resulting executable to be covered by the GNU General Public License.
;; Your use of that executable is in no way restricted on account of
;; linking the GUILE library code into it.
;;
;; This exception does not however invalidate any other reasons why
;; the executable file might be covered by the GNU General Public License.
;;
;; This exception applies only to the code released by the
;; Free Software Foundation under the name GUILE.  If you copy
;; code from other Free Software Foundation releases into a copy of
;; GUILE, as the General Public License permits, the exception does
;; not apply to the code that you add in this way.  To avoid misleading
;; anyone as to the status of such modified files, you must delete
;; this exception notice from them.
;;
;; If you write modifications of your own for GUILE, it is your choice
;; whether to permit this exception to apply to your modifications.
;; If you do not wish that, delete this exception notice.

;;; Author: Thien-Thi Nguyen <address@hidden>

;;; Commentary:

;; Usage: punify [--newline-after-top-level-form] [FILE1 FILE2 ...]
;;
;; Read forms from each FILE (or stdin if no files are specified) and
;; write them to stdout, removing comments and non-essential whitespace.
;; This is useful when installing Scheme source to space-limited media.
;; An exception is made for certain whitespace characters appearing in a
;; string.  They are expanded to their two-character "escaped" form:
;;
;;     #\bel  \a     #\newline  \n     #\ht  \t
;;     #\np   \f     #\cr       \r     #\vt  \v
;;
;; Option `--newline-after-top-level-form' (or `-n' for short) means to
;; output a newline after each top-level form.
;;
;; Example:
;; $ wc ./punify ; ./punify ./punify | wc
;;   163     788    6341 ./punify
;;     0      83    1769
;;
;;
;; Usage from a Scheme program:
;;  (use-modules (scripts punify))
;;  (punify [input ...])
;;
;; Each INPUT is either a filename (string) or an input port.

;;; Code:

(define-module (scripts punify)
  #:autoload (scripts PROGRAM) (HVQC-MAIN)
  #:export (punify))

(define (write-punily form)
  (cond ((vector? form)
         (display #\#)
         (write-punily (vector->list form)))
        ((and (list? form) (not (null? form)))
         (let ((first (car form)))
           (display "(")
           (write-punily first)
           (let loop ((ls (cdr form)) (last-was-list? (list? first)))
             (if (null? ls)
                 (display ")")
                 (let* ((new-first (car ls))
                        (this-is-list? (list? new-first)))
                   (and (not last-was-list?)
                        (not this-is-list?)
                        (display #\space))
                   (write-punily new-first)
                   (loop (cdr ls) this-is-list?))))))
        ((string? form)
         (display #\")
         (let loop ((ls (string->list form)))
           (or (null? ls)
               (let ((c (car ls)))
                 (display (case c
                            ((#\bel)     "\\a")
                            ((#\np)      "\\f")
                            ((#\newline) "\\n")
                            ((#\cr)      "\\r")
                            ((#\ht)      "\\t")
                            ((#\vt)      "\\v")
                            (else c)))
                 (loop (cdr ls)))))
         (display #\"))
        ((and (symbol? form)
              (let ((ls (string->list (symbol->string form))))
                (and (char=? (car ls) #\:)
                     (not (memq #\space ls))
                     (list->string (cdr ls)))))
         => (lambda (symbol-name-after-colon)
              (display #\:)
              (display symbol-name-after-colon)))
        (else (write form))))

(define *newline-after-top-level-form* #f)

(define (punify-one port)
  (let ((toke (lambda () (read port))))
    (let loop ((form (toke)))
      (or (eof-object? form)
          (begin
            (write-punily form)
            (and *newline-after-top-level-form* (newline))
            (loop (toke)))))))

(define (punify . input)
  (for-each (lambda (x)
              (cond ((string? x)
                     (let ((p (open-input-file x)))
                       (punify-one p)
                       (close-port p)))
                    ((port? x)
                     (punify-one x))
                    (else
                     (error "bad input:" x))))
            input))

(define (main args)
  (HVQC-MAIN args (lambda (args)
                    (cond ((and (not (null? (cdr args)))
                                (member (car (cdr args))
                                        '("--newline-after-top-level-form"
                                          "-n")))
                           (set! *newline-after-top-level-form* #t)
                           (set! args (cons (car args) (cddr args)))))
                    (and (null? (cdr args))
                         (set-cdr! args (list (current-input-port))))
                    (apply punify (cdr args)))
             '(usage . commentary)
             '(package . "Guile")))

;;; punify ends here