New file

scripts/ChangeLog

@@ -0,0 +1,5 @@
+2001-04-29  Thien-Thi Nguyen  <ttn@revel.glug.org>
+
+	* Makefile.am, PROGRAM, README, display-commentary,
+	doc-snarf, generate-autoload, punify, use2dot: New file
+

scripts/Makefile.am

@@ -0,0 +1,40 @@
+## Process this file with automake to produce Makefile.in.
+##
+##  	Copyright (C) 2001 Free Software Foundation, Inc.
+##
+##   This file is part of GUILE.
+##
+##   GUILE 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.
+##
+##   GUILE 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 GUILE; see the file COPYING.  If not, write
+##   to the Free Software Foundation, Inc., 59 Temple Place, Suite
+##   330, Boston, MA 02111-1307 USA
+
+AUTOMAKE_OPTIONS = foreign
+
+# These should be installed and distributed.
+scripts_sources =		\
+	PROGRAM			\
+	display-commentary	\
+	doc-snarf		\
+	generate-autoload	\
+	punify			\
+	use2dot
+
+subpkgdatadir = $(pkgdatadir)/$(VERSION)/scripts
+subpkgdata_SCRIPTS = $(scripts_sources)
+
+EXTRA_DIST = $(scripts_sources)
+
+overview:
+	@GUILE_LOAD_PATH=`(cd .. ; pwd)` \
+	./display-commentary $(scripts_sources)

scripts/PROGRAM

@@ -0,0 +1,45 @@
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(scripts PROGRAM)) '\'main')'
+exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@"
+!#
+;;; PROGRAM --- Does something
+
+;; 	Copyright (C) 2001 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
+
+;;; Commentary:
+
+;; Usage: PROGRAM [ARGS]
+;;
+;; PROGRAM does something.
+;;
+;; TODO: Write it!
+;;
+;; Author: J.R.Hacker
+
+;;; Code:
+
+(define-module (scripts PROGRAM)
+  :export (PROGRAM))
+
+(define (PROGRAM . args)
+  #t)
+
+(define main PROGRAM)
+
+;;; PROGRAM ends here

scripts/README

@@ -0,0 +1,76 @@
+Overview and Usage
+------------------
+
+This directory contains Scheme programs, some useful in maintaining Guile.
+On "make install", these programs are copied to PKGDATADIR/VERSION/scripts.
+
+You can invoke a program from the shell, or alternatively, load its file
+as a Guile Scheme module, and use its exported procedure(s) from Scheme code.
+Typically for any PROGRAM:
+
+  (use-modules (scripts PROGRAM))
+  (PROGRAM ARG1 ARG2 ...)
+
+For programs that write to stdout, you might try, instead:
+
+  (use-modules (scripts PROGRAM))
+  (with-output-to-string (lambda () (PROGRAM ARG1 ARG2 ...)))
+
+Note that all args must be strings.
+
+To see PROGRAM's commentary, which may or may not be helpful:
+
+  (help (scripts PROGRAM))
+
+To see all commentaries and module dependencies, try: "make overview".
+
+If you want to try the programs before installing Guile, you will probably
+need to set environment variable GUILE_LOAD_PATH to be the parent directory.
+This can be done in Bourne-compatible shells like so:
+
+  GUILE_LOAD_PATH=`(cd .. ; pwd)`
+  export GUILE_LOAD_PATH
+
+[FIXME: Can someone supply the csh-compatible equivalent?]
+
+
+
+How to Contribute
+-----------------
+
+See template file PROGRAM for a quick start.
+
+Programs must follow the "executable module" convention, documented here:
+
+- The file name must not end in ".scm".
+
+- The file must be executable (chmod +x).
+
+- The module name must be "(scripts PROGRAM)".  A procedure named PROGRAM w/
+  signature "(PROGRAM . args)" must be exported.  Basically, use some variant
+  of the form:
+
+  (define-module (scripts PROGRAM)
+    :export (PROGRAM))
+
+  Feel free to export other definitions useful in the module context.
+
+- There must be the alias:
+
+  (define main PROGRAM)
+
+  However, `main' must NOT be exported.
+
+- The beginning of the file must use the following invocation sequence:
+
+  #!/bin/sh
+  main='(module-ref (resolve-module '\''(scripts PROGRAM)) '\'main')'
+  exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@"
+  !#
+
+Following these conventions allows the program file to be used as module
+(scripts PROGRAM) in addition to as a standalone executable.  Please also
+include a helpful Commentary section w/ some usage info.
+
+
+[README ends here]

scripts/display-commentary

@@ -0,0 +1,47 @@
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(scripts display-commentary)) '\'main')'
+exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@"
+!#
+;;; display-commentary --- As advertized
+
+;; 	Copyright (C) 2001 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
+
+;;; Commentary:
+
+;; Usage: display-commentary FILE1 FILE2 ...
+;;
+;; Display Commentary section from FILE1, FILE2 and so on.
+;;
+;; Author: Thien-Thi Nguyen
+
+;;; Code:
+
+(define-module (scripts display-commentary)
+  :use-module (ice-9 documentation)
+  :export (display-commentary))
+
+(define (display-commentary-one file)
+  (format #t "~A commentary:\n~A" file (file-commentary file)))
+
+(define (display-commentary . files)
+  (for-each display-commentary-one files))
+
+(define main display-commentary)
+
+;;; display-commentary ends here

scripts/doc-snarf

@@ -0,0 +1,442 @@
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(scripts doc-snarf)) '\'main')'
+exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@"
+!#
+;;; doc-snarf --- Extract documentation from source files
+
+;; 	Copyright (C) 2001 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
+
+;;; Commentary:
+
+;; Usage: doc-snarf FILE
+;;
+;; This program reads in a Scheme source file and extracts docstrings
+;; in the format specified below.  Additionally, a procedure protoype
+;; is infered from the procedure definition line starting with
+;; (define... ).
+;;
+;; Currently, two output modi are implemented: texinfo and plaintext.
+;; Default is plaintext, texinfo can be switched on with the
+;; `--texinfo, -t' command line option.
+;;
+;; Format: A docstring can span multiple lines and a docstring line
+;; begins with `;; ' (two semicoli and a space). A docstring is ended
+;; by either a line beginning with (define ...) or one or more lines
+;; beginning with `;;-' (two semicoli and a dash). These lines are
+;; called `options' and begin with a keyword, followed by a colon and
+;; a string.
+;;
+;; Additionally, "standard internal docstrings" (for Scheme source) are
+;; recognized and output as "options".  The output formatting is likely
+;; to change in the future.
+;;
+;; Example:
+
+;; This procedure foos, or bars, depending on the argument @var{braz}.
+;;-Author: Martin Grabmueller
+(define (foo/bar braz)
+  (if braz 'foo 'bar))
+
+;;; Which results in the following docstring if texinfo output is
+;;; enabled:
+#!
+foo/bar
+@deffn procedure foo/bar braz
+This procedure foos, or bars, depending on the argument @var{braz}.
+@c Author: Martin Grabmueller
+@end deffn
+!#
+
+;;; Or in this if plaintext output is used:
+#!
+Procedure: foo/bar braz
+This procedure foos, or bars, depending on the argument @var{braz}.
+;; Author: Martin Grabmueller
+^L
+!#
+
+;; TODO: Convert option lines to alist.
+;;       More parameterization.
+;;       ../libguile/guile-doc-snarf emulation
+
+;;; Author: Martin Grabmueller
+
+(define doc-snarf-version "0.0.2") ; please update before publishing!
+
+;;; Code:
+
+(define-module (scripts doc-snarf)
+  :use-module (ice-9 getopt-long)
+  :use-module (ice-9 regex)
+  :use-module (ice-9 string-fun)
+  :use-module (ice-9 rdelim)
+  :export (doc-snarf))
+
+(define command-synopsis
+  '((version (single-char #\v) (value #f))
+    (help    (single-char #\h) (value #f))
+    (output  (single-char #\o) (value #t))
+    (texinfo (single-char #\t) (value #f))
+    (lang    (single-char #\l) (value #t))))
+
+;; Display version information and exit.
+;;-ttn-mod: use var
+(define (display-version)
+  (display "doc-snarf ") (display doc-snarf-version) (newline))
+
+;; Display the usage help message and exit.
+;;-ttn-mod: change option "source" to "lang"
+(define (display-help)
+  (display "Usage: doc-snarf [options...] inputfile\n")
+  (display "  --help, -h              Show this usage information\n")
+  (display "  --version, -v           Show version information\n")
+  (display
+   "  --output=FILE, -o       Specify output file [default=stdout]\n")
+  (display "  --texinfo, -t           Format output as texinfo\n")
+  (display "  --lang=[c,scheme], -l   Specify the input language\n"))
+
+;; Main program.
+;;-ttn-mod: canonicalize lang
+(define (doc-snarf . args)
+  (let ((options (getopt-long (cons "doc-snarf" args) command-synopsis)))
+    (let ((help-wanted (option-ref options 'help #f))
+	  (version-wanted (option-ref options 'version #f))
+	  (texinfo-wanted (option-ref options 'texinfo #f))
+	  (lang (string->symbol
+                 (string-downcase (option-ref options 'lang "scheme")))))
+      (cond
+       (version-wanted (display-version))
+       (help-wanted (display-help))
+       (else
+	(let ((input (option-ref options '() #f))
+	      (output (option-ref options 'output #f)))
+	  (if
+           ;; Bonard B. Timmons III says `(pair? input)' alone is sufficient.
+           ;; (and input (pair? input))
+           (pair? input)
+           (snarf-file (car input) output texinfo-wanted lang)
+           (display-help))))))))
+
+(define main doc-snarf)
+
+;; Supported languages and their parameters.  Each element has form:
+;; (LANG DOC-START DOC-END DOC-PREFIX OPT-PREFIX SIG-START STD-INT-DOC?)
+;; LANG is a symbol, STD-INT-DOC? is a boolean indicating whether or not
+;; LANG supports "standard internal docstring" (a string after the formals),
+;; everything else is a string specifying a regexp.
+;;-ttn-mod: new var
+(define supported-languages
+  '((c
+     "^/\\*(.*)"
+     "^ \\*/"
+     "^ \\* (.*)"
+     "^ \\*-(.*)"
+     "NOTHING AT THIS TIME!!!"
+     #f
+     )
+    (scheme
+     "^;; (.*)"
+     "^;;\\."
+     "^;; (.*)"
+     "^;;-(.*)"
+     "^\\(define"
+     #t
+     )))
+
+;; Get @var{lang}'s @var{parameter}.  Both args are symbols.
+;;-ttn-mod: new proc
+(define (lang-parm lang parm)
+  (list-ref (assq-ref supported-languages lang)
+            (case parm
+              ((docstring-start)  0)
+              ((docstring-end)    1)
+              ((docstring-prefix) 2)
+              ((option-prefix)    3)
+              ((signature-start)  4)
+              ((std-int-doc?)     5))))
+
+;; Snarf all docstrings from the file @var{input} and write them to
+;; file @var{output}.  Use texinfo format for the output if
+;; @var{texinfo?} is true.
+;;-ttn-mod: don't use string comparison, consult table instead
+(define (snarf-file input output texinfo? lang)
+  (or (memq lang (map car supported-languages))
+      (error "doc-snarf: input language must be c or scheme."))
+  (write-output (snarf input lang) output
+                (if texinfo? format-texinfo format-plain)))
+
+;; fixme: this comment is required to trigger standard internal
+;; docstring snarfing...  ideally, it wouldn't be necessary.
+;;-ttn-mod: new proc, from snarf-docs (aren't these names fun?)
+(define (find-std-int-doc line input-port)
+  "Unread @var{line} from @var{input-port}, then read in the entire form and
+return the standard internal docstring if found.  Return #f if not."
+  (unread-string line input-port)       ; ugh
+  (let ((form (read input-port)))
+    (cond ((and (list? form)            ; (define (PROC ARGS) "DOC" ...)
+                (< 3 (length form))
+                (eq? 'define (car form))
+                (pair? (cadr form))
+                (symbol? (caadr form))
+                (string? (caddr form)))
+           (caddr form))
+          ((and (list? form)            ; (define VAR (lambda ARGS "DOC" ...))
+                (< 2 (length form))
+                (eq? 'define (car form))
+                (symbol? (cadr form))
+                (list? (caddr form))
+                (< 3 (length (caddr form)))
+                (eq? 'lambda (car (caddr form)))
+                (string? (caddr (caddr form))))
+           (caddr (caddr form)))
+          (else #f))))
+
+;; Split @var{string} into lines, adding @var{prefix} to each.
+;;-ttn-mod: new proc
+(define (split-prefixed string prefix)
+  (separate-fields-discarding-char
+   #\newline string
+   (lambda lines
+     (map (lambda (line)
+            (string-append prefix line))
+          lines))))
+
+;; snarf input-file output-file
+;; Extract docstrings from the input file @var{input}, presumed
+;; to be written in language @var{lang}.
+;;-Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
+;;-Created: 2001-02-17
+;;-ttn-mod: regluarize lang parm lookup, add "std int doc" snarfing (2 places)
+(define (snarf input-file lang)
+  (let* ((i-p (open-input-file input-file))
+         (parm-regexp (lambda (parm) (make-regexp (lang-parm lang parm))))
+         (docstring-start  (parm-regexp 'docstring-start))
+         (docstring-end    (parm-regexp 'docstring-end))
+         (docstring-prefix (parm-regexp 'docstring-prefix))
+         (option-prefix    (parm-regexp 'option-prefix))
+         (signature-start  (parm-regexp 'signature-start))
+         (augmented-options
+          (lambda (line i-p options)
+            (let ((int-doc (and (lang-parm lang 'std-int-doc?)
+                                (let ((d (find-std-int-doc line i-p)))
+                                  (and d (split-prefixed d "internal: "))))))
+              (if int-doc
+                  (append (reverse int-doc) options)
+                  options)))))
+
+    (let lp ((line (read-line i-p)) (state 'neutral) (doc-strings '())
+	     (options '()) (entries '()) (lno 0))
+      (cond
+       ((eof-object? line)
+	(close-input-port i-p)
+	(reverse entries))
+
+       ;; State 'neutral: we're currently not within a docstring or
+       ;; option section
+       ((eq? state 'neutral)
+	(let ((m (regexp-exec docstring-start line)))
+	  (if m
+	    (lp (read-line i-p) 'doc-string
+		(list (match:substring m 1)) '() entries (+ lno 1))
+	    (lp (read-line i-p) state '() '() entries (+ lno 1)))))
+
+       ;; State 'doc-string: we have started reading a docstring and
+       ;; are waiting for more, for options or for a define.
+       ((eq? state 'doc-string)
+	(let ((m0 (regexp-exec docstring-prefix line))
+	      (m1 (regexp-exec option-prefix line))
+	      (m2 (regexp-exec signature-start line))
+	      (m3 (regexp-exec docstring-end line)))
+	  (cond
+	   (m0
+	    (lp (read-line i-p) 'doc-string
+		(cons (match:substring m0 1) doc-strings) '() entries
+		(+ lno 1)))
+	   (m1
+	    (lp (read-line i-p) 'options
+		doc-strings (cons (match:substring m1 1) options) entries
+		(+ lno 1)))
+	   (m2
+            (let ((options (augmented-options line i-p options))) ; ttn-mod
+              (lp (read-line i-p) 'neutral '() '()
+                  (cons (parse-entry doc-strings options line input-file lno)
+                        entries)
+                  (+ lno 1))))
+           (m3
+	    (lp (read-line i-p) 'neutral '() '()
+		(cons (parse-entry doc-strings options #f input-file lno)
+		      entries)
+		(+ lno 1)))
+	   (else
+	    (lp (read-line i-p) 'neutral '() '() entries (+ lno 1))))))
+
+       ;; State 'options: We're waiting for more options or for a
+       ;; define.
+       ((eq? state 'options)
+	(let ((m1 (regexp-exec option-prefix line))
+	      (m2 (regexp-exec signature-start line))
+	      (m3 (regexp-exec docstring-end line)))
+	  (cond
+	   (m1
+	    (lp (read-line i-p) 'options
+		doc-strings (cons (match:substring m1 1) options) entries
+		(+ lno 1)))
+	   (m2
+            (let ((options (augmented-options line i-p options))) ; ttn-mod
+              (lp (read-line i-p) 'neutral '() '()
+                  (cons (parse-entry doc-strings options line input-file lno)
+                        entries)
+                  (+ lno 1))))
+	   (m3
+	    (lp (read-line i-p) 'neutral '() '()
+		(cons (parse-entry doc-strings options #f input-file lno)
+		      entries)
+		(+ lno 1)))
+	   (else
+	    (lp (read-line i-p) 'neutral '() '() entries (+ lno 1))))))))))
+
+(define (make-entry symbol signature docstrings options filename line)
+  (vector 'entry symbol signature docstrings options filename line))
+(define (entry-symbol e)
+  (vector-ref e 1))
+(define (entry-signature e)
+  (vector-ref e 2))
+(define (entry-docstrings e)
+  (vector-ref e 3))
+(define (entry-options e)
+  (vector-ref e 4))
+(define (entry-filename e)
+  (vector-ref e 5))
+(define (entry-line e)
+  "This docstring will not be snarfed, unfortunately..."
+  (vector-ref e 6))
+
+;; Create a docstring entry from the docstring line list
+;; @var{doc-strings}, the option line list @var{options} and the
+;; define line @var{def-line}
+(define (parse-entry docstrings options def-line filename line-no)
+;  (write-line docstrings)
+  (cond
+   (def-line
+     (make-entry (get-symbol def-line)
+		 (make-prototype def-line) (reverse docstrings)
+		 (reverse options) filename
+		 (+ (- line-no (length docstrings) (length options)) 1)))
+   ((> (length docstrings) 0)
+    (make-entry (string->symbol (car (reverse docstrings)))
+		(car (reverse docstrings))
+		(cdr (reverse docstrings))
+		(reverse options) filename
+		(+ (- line-no (length docstrings) (length options)) 1)))
+   (else
+    (make-entry 'foo "" (reverse docstrings) (reverse options) filename
+		(+ (- line-no (length docstrings) (length options)) 1)))))
+
+;; Create a string which is a procedure prototype.  The necessary
+;; information for constructing the prototype is taken from the line
+;; @var{def-line}, which is a line starting with @code{(define...}.
+(define (make-prototype def-line)
+  (call-with-input-string
+   def-line
+   (lambda (s-p)
+     (let* ((paren (read-char s-p))
+	    (keyword (read s-p))
+	    (tmp (read s-p)))
+       (cond
+	((pair? tmp)
+	 (join-symbols tmp))
+	((symbol? tmp)
+	 (symbol->string tmp))
+	(else
+	 ""))))))
+
+(define (get-symbol def-line)
+  (call-with-input-string
+   def-line
+   (lambda (s-p)
+     (let* ((paren (read-char s-p))
+	    (keyword (read s-p))
+	    (tmp (read s-p)))
+       (cond
+	((pair? tmp)
+	 (car tmp))
+	((symbol? tmp)
+	 tmp)
+	(else
+	 'foo))))))
+
+;; Append the symbols in the string list @var{s}, separated with a
+;; space character.
+(define (join-symbols s)
+  (cond ((null? s)
+	 "")
+	((symbol? s)
+	 (string-append ". " (symbol->string s)))
+	((null? (cdr s))
+	 (symbol->string (car s)))
+	(else
+	 (string-append (symbol->string (car s)) " " (join-symbols (cdr s))))))
+
+;; Write @var{entries} to @var{output-file} using @var{writer}.
+;; @var{writer} is a proc that takes one entry.
+;; If @var{output-file} is #f, write to stdout.
+;;-ttn-mod: new proc
+(define (write-output entries output-file writer)
+  (with-output-to-port (cond (output-file (open-output-file output-file))
+                             (else (current-output-port)))
+    (lambda () (for-each writer entries))))
+
+;; Write an @var{entry} using texinfo format.
+;;-ttn-mod: renamed from `texinfo-output', distilled
+(define (format-texinfo entry)
+  (display "\n\f")
+  (display (entry-symbol entry))
+  (newline)
+  (display "@c snarfed from ")
+  (display (entry-filename entry))
+  (display ":")
+  (display (entry-line entry))
+  (newline)
+  (display "@deffn procedure ")
+  (display (entry-signature entry))
+  (newline)
+  (for-each (lambda (s) (write-line s))
+            (entry-docstrings entry))
+  (for-each (lambda (s) (display "@c ") (write-line s))
+            (entry-options entry))
+  (write-line "@end deffn"))
+
+;; Write an @var{entry} using plain format.
+;;-ttn-mod: renamed from `texinfo-output', distilled
+(define (format-plain entry)
+  (display "Procedure: ")
+  (display (entry-signature entry))
+  (newline)
+  (for-each (lambda (s) (write-line s))
+            (entry-docstrings entry))
+  (for-each (lambda (s) (display ";; ") (write-line s))
+            (entry-options entry))
+  (display "Snarfed from ")
+  (display (entry-filename entry))
+  (display ":")
+  (display (entry-line entry))
+  (newline)
+  (write-line "\f"))
+
+;;; doc-snarf ends here

scripts/generate-autoload

@@ -0,0 +1,138 @@
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(scripts generate-autoload)) '\'main')'
+exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@"
+!#
+;;; generate-autoload --- Display define-module form with autoload info
+
+;; 	Copyright (C) 2001 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
+
+;;; Commentary:
+
+;; Usage: generate-autoload [OPTIONS] FILE1 FILE2 ...
+;;
+;; The autoload form is displayed to standard output:
+;;
+;; (define-module (guile-user)
+;;   :autoload (ZAR FOO) (FOO-1 FOO-2 ...)
+;;     :
+;;     :
+;;   :autoload (ZAR BAR) (BAR-1 BAR-2 ...))
+;;
+;; For each file, a symbol triggers an autoload if it is found in one
+;; of these situations:
+;;  - in the `:export' clause of a `define-module' form;
+;;  - in a top-level `export' or `export-syntax' form;
+;;  - in a `define-public' form.
+;;
+;; The module name is inferred from the `define-module' form.  If either the
+;; module name or the exports list cannot be determined, no autoload entry is
+;; generated for that file.
+;;
+;; Options:
+;; --target MODULE-NAME         -- Use MODULE-NAME instead of `(guile-user)'.
+;;                                 Note that some shells may require you to
+;;                                 quote the argument to handle parentheses
+;;                                 and spaces.
+;;
+;; Usage examples from Scheme code as a module:
+;; (use-modules (scripts generate-autoload))
+;; (generate-autoload "generate-autoload")
+;; (generate-autoload "--target" "(my module)" "generate-autoload")
+;; (apply generate-autoload "--target" "(my module)" '("foo" "bar" "baz"))
+;;
+;; Author: Thien-Thi Nguyen
+
+;;; Code:
+
+(define-module (scripts generate-autoload)
+  :export (generate-autoload))
+
+(define (autoload-info file)
+  (let ((p (open-input-file file)))
+    (let loop ((form (read p)) (module-name #f) (exports '()))
+      (if (eof-object? form)
+          (and module-name
+               (not (null? exports))
+               (list module-name exports)) ; ret
+          (cond ((and (list? form)
+                      (< 1 (length form))
+                      (eq? 'define-module (car form)))
+                 (loop (read p)
+                       (cadr form)
+                       (cond ((member ':export form)
+                              => (lambda (val)
+                                   (append (cadr val) exports)))
+                             (else exports))))
+                ((and (list? form)
+                      (< 1 (length form))
+                      (memq (car form) '(export export-syntax)))
+                 (loop (read p)
+                       module-name
+                       (append (cdr form) exports)))
+                ((and (list? form)
+                      (< 2 (length form))
+                      (eq? 'define-public (car form))
+                      (list? (cadr form))
+                      (symbol? (caadr form)))
+                 (loop (read p)
+                       module-name
+                       (cons (caadr form) exports)))
+                ((and (list? form)
+                      (< 2 (length form))
+                      (eq? 'define-public (car form))
+                      (symbol? (cadr form)))
+                 (loop (read p)
+                       module-name
+                       (cons (cadr form) exports)))
+                (else (loop (read p) module-name exports)))))))
+
+(define (generate-autoload . args)
+  (let* ((module-count 0)
+         (syms-count 0)
+         (target-override (cond ((member "--target" args) => cadr)
+                                (else #f)))
+         (files (if target-override (cddr args) (cdr args))))
+    (display ";;; do not edit --- generated ")
+    (display (strftime "%Y-%m-%d %H:%M:%S" (localtime (current-time))))
+    (newline)
+    (display "(define-module ")
+    (display (or target-override "(guile-user)"))
+    (for-each (lambda (file)
+                (cond ((autoload-info file)
+                       => (lambda (info)
+                            (and info
+                                 (apply (lambda (module-name exports)
+                                          (set! module-count (1+ module-count))
+                                          (set! syms-count (+ (length exports)
+                                                              syms-count))
+                                          (for-each display
+                                                    (list "\n  :autoload "
+                                                          module-name " "
+                                                          exports)))
+                                        info))))))
+              files)
+    (display ")")
+    (newline)
+    (for-each display (list "  ;;; "
+                            syms-count " symbols in "
+                            module-count " modules\n"))))
+
+(define main generate-autoload)
+
+;;; generate-autoload ends here

scripts/punify

@@ -0,0 +1,81 @@
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(scripts punify)) '\'main')'
+exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@"
+!#
+;;; punify --- Display Scheme code w/o unnecessary comments / whitespace
+
+;; 	Copyright (C) 2001 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
+
+;;; Commentary:
+
+;; Usage: punify FILE1 FILE2 ...
+;;
+;; Each file's forms are read and written to stdout.
+;; The effect is to remove comments and much non-essential whitespace.
+;; This is useful when installing Scheme source to space-limited media.
+;;
+;; Example:
+;; $ wc ./punify ; ./punify ./punify | wc
+;;     81     355    2622 ./punify
+;;      0      34     694
+;;
+;; TODO: Read from stdin.
+;;       Handle vectors.
+;;       Identifier punification.
+;;
+;; Author: Thien-Thi Nguyen
+
+;;; Code:
+
+(define-module (scripts punify)
+  :export (punify))
+
+(define (write-punily form)
+  (if (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 " "))
+                (write-punily new-first)
+                (loop (cdr ls) this-is-list?)))))
+      (write form)))
+
+(define (punify-one file)
+  (with-input-from-file file
+    (lambda ()
+      (let ((toke (lambda () (read (current-input-port)))))
+        (let loop ((form (toke)))
+          (or (eof-object? form)
+              (begin
+                (write-punily form)
+                (loop (toke)))))))))
+
+(define (punify . args)
+  (for-each punify-one args))
+
+(define main punify)
+
+;;; punify ends here

scripts/use2dot

@@ -0,0 +1,166 @@
+#!/bin/sh
+# aside from this initial boilerplate, this is actually -*- scheme -*- code
+main='(module-ref (resolve-module '\''(scripts use2dot)) '\'main')'
+exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@"
+!#
+;;; use2dot --- Display module dependencies as a DOT specification
+
+;; 	Copyright (C) 2001 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
+
+;;; Commentary:
+
+;; Usage: use2dot [OPTIONS] [FILE ...]
+;; Display to stdout a DOT specification that describes module dependencies
+;; in FILEs.
+;;
+;; A top-level `use-modules' form or a `:use-module' `define-module'-component
+;; results in a "solid" style edge.
+;;
+;; An `:autoload' `define-module'-component results in a "dotted" style edge
+;; with label "N" indicating that N names are responsible for triggering the
+;; autoload.
+;;
+;; A top-level `load' or `primitive-load' form results in a a "bold" style
+;; edge to a node named with either the file name if the `load' argument is a
+;; string, or "[computed in FILE]" otherwise.
+;;
+;; Options:
+;; --default-module MOD  -- Set MOD as the default module (for top-level
+;;                          `use-modules' forms that do not follow some
+;;                          `define-module' form in a file).  MOD should be
+;;                          be a list or `#f', in which case such top-level
+;;                          `use-modules' forms are effectively ignored.
+;;                          Default value: `(guile)'.
+;;
+;; TODO
+;; - add `--load-synonyms' option
+;; - add `--ignore-module' option
+;; - handle arbitrary command-line key/value configuration
+;;
+;; Author: Thien-Thi Nguyen based on PERL script by Keisuke Nishida
+
+;;; Code:
+
+(define-module (scripts use2dot)
+  :use-module (ice-9 regex))
+
+(define (string-append/separator separator strings)
+  ;; from (ttn stringutils) -- todo: use srfi-13
+  ;;   "Append w/ SEPARATOR a list of STRINGS.
+  ;; SEPARATOR can be a character or a string."
+  (let ((rev (reverse strings))
+        (sep (if (char? separator)
+                 (make-string 1 separator)
+                 separator)))
+    (apply string-append
+           (let loop ((s (cdr rev))
+                      (acc (list (car rev))))
+             (if (null? s)
+                 acc
+                 (loop (cdr s)
+                       (cons (car s)
+                             (cons sep acc))))))))
+
+(define (mapconcat proc ls sep)
+  ;; from (ttn stringutils) -- todo: use srfi-13
+  ;; "Map PROC over LS, concatening resulting strings with separator SEP."
+  (string-append/separator sep (map proc ls)))
+
+(define default-module '(guile))
+
+(define (q s)                           ; quote
+  (format #f "~S" s))
+
+(define (vv pair)                       ; var=val
+  (format #f "~A=~A" (car pair) (cdr pair)))
+
+(define (spew module use . etc)
+  (and module
+       (let ((etc-spec (if (null? etc)
+                           ""
+                           (format #f " [~A]" (mapconcat vv etc ",")))))
+         (format #t "  \"~A\" -> \"~A\"~A;\n" module use etc-spec))))
+
+(define (header)
+  (format #t "digraph use2dot {")
+  (for-each (lambda (s) (format #t "  ~A;\n" s))
+            (map vv `((label . ,(q "Guile Module Dependencies"))
+                      ;(rankdir . LR)
+                      ;(size . ,(q "7.5,10"))
+                      (ratio . fill)
+                      ;(nodesep . ,(q "0.05"))
+                      ))))
+
+(define (grok filename)
+  (let* ((p (open-file filename "r"))
+         (next (lambda () (read p)))
+         (curmod #f))
+    (let loop ((form (next)))
+      (cond ((eof-object? form))
+            ((not (list? form)) (loop (next)))
+            (else (case (car form)
+                    ((define-module)
+                     (let ((module (cadr form)))
+                       (set! curmod module)
+                       (let loop ((ls form))
+                         (or (null? ls)
+                             (case (car ls)
+                               ((:use-module)
+                                (spew module (cadr ls))
+                                (loop (cddr ls)))
+                               ((:autoload)
+                                (spew module (cadr ls)
+                                      '(style . dotted)
+                                      '(fontsize . 5)
+                                      (let ((len (length (caddr ls))))
+                                        `(label . ,(q (number->string len)))))
+                                (loop (cdddr ls)))
+                               (else (loop (cdr ls))))))))
+                    ((use-modules)
+                     (for-each (lambda (use)
+                                 (spew (or curmod default-module) use))
+                               (cdr form)))
+                    ((load primitive-load)
+                     (spew (or curmod default-module)
+                           (let ((file (cadr form)))
+                             (if (string? file)
+                                 file
+                                 (format #f "[computed in ~A]" filename)))
+                           '(style . bold))))
+                  (loop (next)))))))
+
+(define (body files)
+  (for-each grok files))
+
+(define (footer)
+  (format #t "}"))
+
+(define (use2dot . args)
+  (header)
+  (let* ((override (cond ((member "--default-module" args) => cadr)
+                         (else #f)))
+         (files (if override (cddr args) args)))
+    (and override
+         (set! default-module
+               (with-input-from-string override (lambda () (read)))))
+    (body files))
+  (footer))
+
+(define main use2dot)
+
+;;; use2dot ends here