summaryrefslogtreecommitdiff
path: root/module/scripts
diff options
context:
space:
mode:
Diffstat (limited to 'module/scripts')
-rw-r--r--module/scripts/ChangeLog-2008319
-rw-r--r--module/scripts/README63
-rw-r--r--module/scripts/api-diff.scm179
-rw-r--r--module/scripts/autofrisk.scm218
-rw-r--r--module/scripts/compile.scm257
-rw-r--r--module/scripts/disassemble.scm38
-rw-r--r--module/scripts/display-commentary.scm67
-rw-r--r--module/scripts/doc-snarf.scm439
-rw-r--r--module/scripts/frisk.scm290
-rw-r--r--module/scripts/generate-autoload.scm144
-rw-r--r--module/scripts/help.scm188
-rw-r--r--module/scripts/lint.scm318
-rw-r--r--module/scripts/list.scm91
-rw-r--r--module/scripts/punify.scm87
-rw-r--r--module/scripts/read-rfc822.scm131
-rw-r--r--module/scripts/read-scheme-source.scm282
-rw-r--r--module/scripts/read-text-outline.scm253
-rw-r--r--module/scripts/scan-api.scm223
-rw-r--r--module/scripts/snarf-check-and-output-texi.scm311
-rw-r--r--module/scripts/snarf-guile-m4-docs.scm86
-rw-r--r--module/scripts/summarize-guile-TODO.scm213
-rw-r--r--module/scripts/use2dot.scm110
22 files changed, 4307 insertions, 0 deletions
diff --git a/module/scripts/ChangeLog-2008 b/module/scripts/ChangeLog-2008
new file mode 100644
index 000000000..feef87dfd
--- /dev/null
+++ b/module/scripts/ChangeLog-2008
@@ -0,0 +1,319 @@
+2004-11-09 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * snarf-check-and-output-texi (process-multiline-directive): Allow
+ the fname attribute to a sequence of strings and append them all
+ to form the fname. This is needed for string literals like
+ "u8""vector?".
+
+2004-09-08 Marius Vollmer <marius.vollmer@uni-dortmund.de>
+
+ * Makefile.am (scripts_sources): Added snarf-guile-m4-docs.
+
+2004-08-06 Kevin Ryde <user42@zip.com.au>
+
+ * scripts/read-rfc822 (parse-message): Correction to header
+ continuation, loop with read-line not cdr lines.
+
+2002-12-08 Rob Browning <rlb@defaultvalue.org>
+
+ * Makefile.am (subpkgdatadir): VERSION -> GUILE_EFFECTIVE_VERSION.
+
+2002-10-26 Neil Jerram <neil@ossau.uklinux.net>
+
+ * lint (lint): Add message telling resolved module name.
+
+2002-10-05 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * snarf-check-and-output-texi (end-multiline): Use '*function-name*'
+ instead of nonexisting 'name'.
+
+2002-10-04 Rob Browning <rlb@defaultvalue.org>
+
+ * summarize-guile-TODO (as-leaf): make #\: a char-set.
+
+2002-05-18 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * api-diff (group-diff): Also output +N and -N adds and subs
+ details, respectively.
+
+2002-05-13 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * read-rfc822: New script.
+
+ * Makefile.am (scripts_sources): Add api-diff and read-rfc822.
+
+ * scan-api (scan-api): No longer include timestamp.
+
+2002-05-11 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * scan-api (scan-api): Fix bug: No longer omit `C' and `Scheme' in
+ groups in the presence of the grouper.
+
+ * api-diff: Use modules (ice-9 format), (ice-9 getopt-long).
+ Autoload module (srfi srfi-13).
+ No longer export `diff-alists'.
+
+ (diff, diff-alists, display-list): Remove.
+ (put, get, read-api-alist-file, hang-by-the-roots, diff?,
+ diff+note!, group-diff): New procs.
+ (api-diff): Rewrite.
+
+2002-05-10 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * scan-api (add-props): New proc.
+ (make-grok-proc): Renamed from `make-grok-hook'.
+ (make-members-proc): Renamed from `make-members-hook'.
+ (make-grouper): Renamed from `make-grouping-hook'. Update callers.
+ Add handling for multiple grouping-defs files.
+ (scan-api): Add handling for multiple grouping-defs files.
+ Cache `symbol->string' result; adjust `sort' usage.
+
+2002-05-09 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * scan-api (scan-C!): Use more robust regexp.
+
+2002-05-08 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * scan-api: New script.
+ (scan-api): Handle case where `grouping-hook' is #f.
+
+ Remove top-level `debug-enable' form.
+ Add TODO comment; nfc.
+
+ * Makefile.am (scripts_sources): Add "scan-api".
+
+2002-04-30 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * summarize-guile-TODO (make-display-item):
+ Hoist some lambdas; nfc.
+
+2002-04-29 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * summarize-guile-TODO: Fix commentary typo; nfc.
+
+2002-04-08 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * summarize-guile-TODO: Use (ice-9 getopt-long).
+ Autoload (ice-9 common-list).
+
+ (select-items): New proc.
+ (make-display-item): New proc.
+ (display-item): Delete.
+ (display-items): Use `make-display-item'.
+ (summarize-guile-TODO): Add option handling.
+
+2002-04-07 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * summarize-guile-TODO: Add "Bugs" section to commentary.
+ Autoload (srfi srfi-13) on `string-tokenize'.
+
+ (as-leaf): New proc.
+ (hang-by-the-leaves): Use `as-leaf'.
+ (read-TODO-file): Expand regexp and specs
+ to handle "D", "X" and "N%". Fix regexp
+ to make isolating `who' easier.
+ (display-item): Handle "D", "X" and "N%".
+
+2002-04-06 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * summarize-guile-TODO: New script.
+
+ * Makefile.am (scripts_sources): Add "summarize-guile-TODO".
+
+2002-04-05 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * read-text-outline (display-outline-tree): No longer export this proc.
+
+ (*depth-cue-rx*, *subm-number*, *level-divisor*, >>,
+ display-outline-tree): Delete these vars and procs.
+
+ (??, msub, ??-predicates, make-line-parser,
+ make-text-outline-reader): New procs.
+
+ (make-text-outline-reader): Export.
+ (read-text-outline-silently): Rewrite
+ using `make-text-outline-reader'.
+
+2002-04-04 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * lint: New script.
+
+ * Makefile.am (scripts_sources): Add "lint".
+
+2002-04-02 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * PROGRAM: Update copyright; nfc.
+
+ * read-text-outline: New script.
+
+ * Makefile.am (scripts_sources): Add "read-text-outline".
+
+ * read-text-outline (read-text-outline-silently):
+ Move `tp' inside `loop'; nfc.
+
+2002-03-12 Neil Jerram <neil@ossau.uklinux.net>
+
+ * snarf-check-and-output-texi (snarf-check-and-output-texi): If
+ supplied, the `--manual' flag arrives as a string, not a symbol,
+ so test for it as such.
+
+2002-03-03 Neil Jerram <neil@ossau.uklinux.net>
+
+ * snarf-guile-m4-docs (display-texi): Strip off `# ' from start of
+ docstring lines if possible, rather than just `#'.
+
+2002-02-26 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Makefile.am: Update path to pre-inst-guile automake frag.
+
+2002-02-22 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * api-diff: New script.
+
+2002-02-05 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Include $(top_srcdir)/pre-inst-guile.am.
+
+ (overview): Use $(preinstguiletool).
+
+2002-01-11 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Makefile.am (scripts_sources): Add autofrisk.
+
+ * autofrisk: New script.
+
+ * frisk: Fix typo in commentary; nfc.
+
+ * use2dot: Autoload module (ice-9 getopt-long).
+ Use module (srfi srfi-13).
+ Export `use2dot'.
+
+ (string-append/separator, mapconcat): Delete.
+ (vv): Now take list of pairs, and return the mapping..
+ (>>header): Use `string-join'.
+ (>>): New proc.
+ (use2dot): Use `getopt-long'. Use `>>'.
+
+2002-01-08 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * Makefile.am (scripts_sources): Add frisk.
+ (list): New target.
+ (overview): Also report module interfaces.
+
+ * use2dot: Rewrite using (scripts frisk).
+
+ * frisk: Initial revision.
+
+2002-01-02 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * snarf-guile-m4-docs: New script.
+
+2001-11-28 Thien-Thi Nguyen <ttn@giblet.glug.org>
+
+ * punify (write-punily): Handle symbols w/ ":" prefix specially.
+
+ * use2dot (ferret): New proc.
+ (grok): Use `ferret'.
+
+2001-11-16 Neil Jerram <neil@ossau.uklinux.net>
+
+ * snarf-check-and-output-texi: Change generated @deffn categories
+ from "function" and "primitive" to "C Function" and "Scheme
+ Procedure".
+ (end-multiline): Take out @findex generation again; not needed
+ since index entries are implicit in @deffn forms.
+
+ These changes add a @deffnx C function declaration and function
+ index entries for each Guile primitive to the copy of the doc
+ snarf output that is used for reference manual synchronization.
+ Online help is unchanged.
+
+ * snarf-check-and-output-texi (*manual-flag*,
+ snarf-check-and-output-texi): Handle `--manual' invocation arg
+ passed through from libguile/Makefile.am.
+ (*c-function-name*, begin-multiline, do-command): Pick out C
+ function name from snarfed token stream.
+ (end-multiline): Add @deffnx C declaration and function index
+ entries to output.
+ (*primitive-deffnx-signature*, *primitive-deffnx-sig-length*):
+ Fluff to help insert the C declaration after any "@deffnx
+ primitive" lines in the snarfed docstring.
+
+2001-10-05 Thien-Thi Nguyen <ttn@glug.org>
+
+ * read-scheme-source (quoted?, clump): New procs, exported.
+
+2001-09-30 Thien-Thi Nguyen <ttn@glug.org>
+
+ * display-commentary (module-name->filename-frag,
+ display-module-commentary): New procs.
+ (display-commentary): Also handle refs that look like module
+ names.
+
+2001-08-25 Marius Vollmer <mvo@zagadka.ping.de>
+
+ * Makefile.am (AUTOMAKE_OPTIONS): Change "foreign" to "gnu".
+
+2001-08-07 Michael Livshin <mlivshin@bigfoot.com>
+
+ * snarf-check-and-output-texi: print optional args in a prettier
+ manner.
+
+2001-08-01 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * PROGRAM, README, display-commentary, doc-snarf,
+ generate-autoload, punify, read-scheme-source,
+ snarf-check-and-output-texi, use2dot:
+ In boilerplate, use -l$0.
+ Thanks to Daniel Skarda.
+
+2001-07-22 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * generate-autoload (autoload-info):
+ Also handle `defmacro-public' forms.
+
+2001-07-14 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * PROGRAM, display-commentary, doc-snarf, generate-autoload,
+ punify, read-scheme-source, snarf-check-and-output-texi, use2dot:
+ Re-add authorship info.
+
+2001-07-12 Michael Livshin <mlivshin@bigfoot.com>
+
+ * snarf-check-and-output-texi (do-argpos): complain to the stderr,
+ not stdout. thanks to Dale P. Smith!
+ (nice-sig): cosmetic fix.
+
+2001-07-09 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * PROGRAM, generate-autoload, use2dot, punify, display-commentary,
+ doc-snarf, read-scheme-source, snarf-check-and-output-texi:
+ Remove authorship info.
+
+2001-06-25 Michael Livshin <mlivshin@bigfoot.com>
+
+ * snarf-check-and-output-texi: rewrite.
+
+2001-05-31 Michael Livshin <mlivshin@bigfoot.com>
+
+ * snarf-check-and-output-texi: new file.
+
+ * Makefile.am (scripts_sources): add snarf-check-and-output-texi.
+
+2001-05-14 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * PROGRAM, display-commentary, doc-snarf, generate-autoload,
+ punify, read-scheme-source, use2dot: Move author tag outside
+ commentary; nfc.
+
+2001-05-08 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * read-scheme-source: New file
+
+ * Makefile.am (scripts_sources): Add read-scheme-source.
+
+2001-04-29 Thien-Thi Nguyen <ttn@revel.glug.org>
+
+ * Makefile.am, PROGRAM, README, display-commentary,
+ doc-snarf, generate-autoload, punify, use2dot: New file
+
diff --git a/module/scripts/README b/module/scripts/README
new file mode 100644
index 000000000..0f5bea583
--- /dev/null
+++ b/module/scripts/README
@@ -0,0 +1,63 @@
+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 use guild to 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))
+
+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 "guild" convention, documented here:
+
+- 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.
+
+Following these conventions allows the program file to be used as module
+(scripts PROGRAM) in addition to being invoked by guild. Please also
+include a helpful Commentary section w/ some usage info.
+
+
+[README ends here]
diff --git a/module/scripts/api-diff.scm b/module/scripts/api-diff.scm
new file mode 100644
index 000000000..b2527b9e9
--- /dev/null
+++ b/module/scripts/api-diff.scm
@@ -0,0 +1,179 @@
+;;; api-diff --- diff guile-api.alist files
+
+;; Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: api-diff [-d GROUPS] ALIST-FILE-A ALIST-FILE-B
+;;
+;; Read in the alists from files ALIST-FILE-A and ALIST-FILE-B
+;; and display a (count) summary of the groups defined therein.
+;; Optional arg "--details" (or "-d") specifies a comma-separated
+;; list of groups, in which case api-diff displays instead the
+;; elements added and deleted for each of the specified groups.
+;;
+;; For scheme programming, this module exports the proc:
+;; (api-diff A-file B-file)
+;;
+;; Note that the convention is that the "older" alist/file is
+;; specified first.
+;;
+;; TODO: Develop scheme interface.
+
+;;; Code:
+
+(define-module (scripts api-diff)
+ :use-module (ice-9 common-list)
+ :use-module (ice-9 format)
+ :use-module (ice-9 getopt-long)
+ :autoload (srfi srfi-13) (string-tokenize)
+ :export (api-diff))
+
+(define %include-in-guild-list #f)
+(define %summary "Show differences between two scan-api files.")
+
+(define (read-alist-file file)
+ (with-input-from-file file
+ (lambda () (read))))
+
+(define put set-object-property!)
+(define get object-property)
+
+(define (read-api-alist-file file)
+ (let* ((alist (read-alist-file file))
+ (meta (assq-ref alist 'meta))
+ (interface (assq-ref alist 'interface)))
+ (put interface 'meta meta)
+ (put interface 'groups (let ((ht (make-hash-table 31)))
+ (for-each (lambda (group)
+ (hashq-set! ht group '()))
+ (assq-ref meta 'groups))
+ ht))
+ interface))
+
+(define (hang-by-the-roots interface)
+ (let ((ht (get interface 'groups)))
+ (for-each (lambda (x)
+ (for-each (lambda (group)
+ (hashq-set! ht group
+ (cons (car x)
+ (hashq-ref ht group))))
+ (assq-ref x 'groups)))
+ interface))
+ interface)
+
+(define (diff? a b)
+ (let ((result (set-difference a b)))
+ (if (null? result)
+ #f ; CL weenies bite me
+ result)))
+
+(define (diff+note! a b note-removals note-additions note-same)
+ (let ((same? #t))
+ (cond ((diff? a b) => (lambda (x) (note-removals x) (set! same? #f))))
+ (cond ((diff? b a) => (lambda (x) (note-additions x) (set! same? #f))))
+ (and same? (note-same))))
+
+(define (group-diff i-old i-new . options)
+ (let* ((i-old (hang-by-the-roots i-old))
+ (g-old (hash-fold acons '() (get i-old 'groups)))
+ (g-old-names (map car g-old))
+ (i-new (hang-by-the-roots i-new))
+ (g-new (hash-fold acons '() (get i-new 'groups)))
+ (g-new-names (map car g-new)))
+ (cond ((null? options)
+ (diff+note! g-old-names g-new-names
+ (lambda (removals)
+ (format #t "groups-removed: ~A\n" removals))
+ (lambda (additions)
+ (format #t "groups-added: ~A\n" additions))
+ (lambda () #t))
+ (for-each (lambda (group)
+ (let* ((old (assq-ref g-old group))
+ (new (assq-ref g-new group))
+ (old-count (and old (length old)))
+ (new-count (and new (length new)))
+ (delta (and old new (- new-count old-count))))
+ (format #t " ~5@A ~5@A : "
+ (or old-count "-")
+ (or new-count "-"))
+ (cond ((and old new)
+ (let ((add-count 0) (sub-count 0))
+ (diff+note!
+ old new
+ (lambda (subs)
+ (set! sub-count (length subs)))
+ (lambda (adds)
+ (set! add-count (length adds)))
+ (lambda () #t))
+ (format #t "~5@D ~5@D : ~5@D"
+ add-count (- sub-count) delta)))
+ (else
+ (format #t "~5@A ~5@A : ~5@A" "-" "-" "-")))
+ (format #t " ~A\n" group)))
+ (sort (union g-old-names g-new-names)
+ (lambda (a b)
+ (string<? (symbol->string a)
+ (symbol->string b))))))
+ ((assq-ref options 'details)
+ => (lambda (groups)
+ (for-each (lambda (group)
+ (let* ((old (or (assq-ref g-old group) '()))
+ (new (or (assq-ref g-new group) '()))
+ (>>! (lambda (label ls)
+ (format #t "~A ~A:\n" group label)
+ (for-each (lambda (x)
+ (format #t " ~A\n" x))
+ ls))))
+ (diff+note! old new
+ (lambda (removals)
+ (>>! 'removals removals))
+ (lambda (additions)
+ (>>! 'additions additions))
+ (lambda ()
+ (format #t "~A: no changes\n"
+ group)))))
+ groups)))
+ (else
+ (error "api-diff: group-diff: bad options")))))
+
+(define (api-diff . args)
+ (let* ((p (getopt-long (cons 'api-diff args)
+ '((details (single-char #\d)
+ (value #t))
+ ;; Add options here.
+ )))
+ (rest (option-ref p '() '("/dev/null" "/dev/null")))
+ (i-old (read-api-alist-file (car rest)))
+ (i-new (read-api-alist-file (cadr rest)))
+ (options '()))
+ (cond ((option-ref p 'details #f)
+ => (lambda (groups)
+ (set! options (cons (cons 'details
+ (map string->symbol
+ (string-tokenize
+ groups
+ #\,)))
+ options)))))
+ (apply group-diff i-old i-new options)))
+
+(define main api-diff)
+
+;;; api-diff ends here
diff --git a/module/scripts/autofrisk.scm b/module/scripts/autofrisk.scm
new file mode 100644
index 000000000..9bce06e2a
--- /dev/null
+++ b/module/scripts/autofrisk.scm
@@ -0,0 +1,218 @@
+;;; autofrisk --- Generate module checks for use with auto* tools
+
+;; Copyright (C) 2002, 2006, 2009, 2011 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: autofrisk [file]
+;;
+;; This program looks for the file modules.af in the current directory
+;; and writes out modules.af.m4 containing autoconf definitions.
+;; If given, look for FILE instead of modules.af and output to FILE.m4.
+;;
+;; After running autofrisk, you should add to configure.ac the lines:
+;; AUTOFRISK_CHECKS
+;; AUTOFRISK_SUMMARY
+;; Then run "aclocal -I ." to update aclocal.m4, and finally autoconf.
+;;
+;; The modules.af file consists of a series of configuration forms (Scheme
+;; lists), which have one of the following formats:
+;; (files-glob PATTERN ...)
+;; (non-critical-external MODULE ...)
+;; (non-critical-internal MODULE ...)
+;; (programs (MODULE PROG ...) ...)
+;; (pww-varname VARNAME)
+;; PATTERN is a string that may contain "*" and "?" characters to be
+;; expanded into filenames. MODULE is a list of symbols naming a
+;; module, such as `(srfi srfi-1)'. VARNAME is a shell-safe name to use
+;; instead of "probably_wont_work", the default. This var is passed to
+;; `AC_SUBST'. PROG is a string.
+;;
+;; Only the `files-glob' form is required.
+;;
+;; TODO: Write better commentary.
+;; Make "please see README" configurable.
+
+;;; Code:
+
+(define-module (scripts autofrisk)
+ :autoload (ice-9 popen) (open-input-pipe)
+ :use-module (srfi srfi-1)
+ :use-module (srfi srfi-8)
+ :use-module (srfi srfi-13)
+ :use-module (srfi srfi-14)
+ :use-module (scripts read-scheme-source)
+ :use-module (scripts frisk)
+ :export (autofrisk))
+
+(define %include-in-guild-list #f)
+(define %summary "Generate snippets for use in configure.ac files.")
+
+(define *recognized-keys* '(files-glob
+ non-critical-external
+ non-critical-internal
+ programs
+ pww-varname))
+
+(define (canonical-configuration forms)
+ (let ((chk (lambda (condition . x)
+ (or condition (apply error "syntax error:" x)))))
+ (chk (list? forms) "input not a list")
+ (chk (every list? forms) "non-list element")
+ (chk (every (lambda (form) (< 1 (length form))) forms) "list too short")
+ (let ((un #f))
+ (chk (every (lambda (form)
+ (let ((key (car form)))
+ (and (symbol? key)
+ (or (eq? 'quote key)
+ (memq key *recognized-keys*)
+ (begin
+ (set! un key)
+ #f)))))
+ forms)
+ "unrecognized key:" un))
+ (let ((bunched (map (lambda (key)
+ (fold (lambda (form so-far)
+ (or (and (eq? (car form) key)
+ (cdr form)
+ (append so-far (cdr form)))
+ so-far))
+ (list key)
+ forms))
+ *recognized-keys*)))
+ (lambda (key)
+ (assq-ref bunched key)))))
+
+(define (>>strong modules)
+ (for-each (lambda (module)
+ (format #t "GUILE_MODULE_REQUIRED~A\n" module))
+ modules))
+
+(define (safe-name module)
+ (let ((var (object->string module)))
+ (string-map! (lambda (c)
+ (if (char-set-contains? char-set:letter+digit c)
+ c
+ #\_))
+ var)
+ var))
+
+(define *pww* "probably_wont_work")
+
+(define (>>weak weak-edges)
+ (for-each (lambda (edge)
+ (let* ((up (edge-up edge))
+ (down (edge-down edge))
+ (var (format #f "have_guile_module~A" (safe-name up))))
+ (format #t "GUILE_MODULE_AVAILABLE(~A, ~A)\n" var up)
+ (format #t "test \"$~A\" = no &&\n ~A=\"~A $~A\"~A"
+ var *pww* down *pww* "\n\n")))
+ weak-edges))
+
+(define (>>program module progs)
+ (let ((vars (map (lambda (prog)
+ (format #f "guile_module~Asupport_~A"
+ (safe-name module)
+ prog))
+ progs)))
+ (for-each (lambda (var prog)
+ (format #t "AC_PATH_PROG(~A, ~A)\n" var prog))
+ vars progs)
+ (format #t "test \\\n")
+ (for-each (lambda (var)
+ (format #t " \"$~A\" = \"\" -o \\\n" var))
+ vars)
+ (format #t "~A &&\n~A=\"~A $~A\"\n\n"
+ (list-ref (list "war = peace"
+ "freedom = slavery"
+ "ignorance = strength")
+ (random 3))
+ *pww* module *pww*)))
+
+(define (>>programs programs)
+ (for-each (lambda (form)
+ (>>program (car form) (cdr form)))
+ programs))
+
+(define (unglob pattern)
+ (let ((p (open-input-pipe (format #f "echo '(' ~A ')'" pattern))))
+ (map symbol->string (read p))))
+
+(define (>>checks forms)
+ (let* ((cfg (canonical-configuration forms))
+ (files (apply append (map unglob (cfg 'files-glob))))
+ (ncx (cfg 'non-critical-external))
+ (nci (cfg 'non-critical-internal))
+ (report ((make-frisker) files))
+ (external (report 'external)))
+ (let ((pww-varname (cfg 'pww-varname)))
+ (or (null? pww-varname) (set! *pww* (car pww-varname))))
+ (receive (weak strong)
+ (partition (lambda (module)
+ (or (member module ncx)
+ (every (lambda (i)
+ (member i nci))
+ (map edge-down (mod-down-ls module)))))
+ external)
+ (format #t "AC_DEFUN([AUTOFRISK_CHECKS],[\n\n")
+ (>>strong strong)
+ (format #t "\n~A=~S\n\n" *pww* "")
+ (>>weak (fold (lambda (module so-far)
+ (append so-far (mod-down-ls module)))
+ (list)
+ weak))
+ (>>programs (cfg 'programs))
+ (format #t "AC_SUBST(~A)\n])\n\n" *pww*))))
+
+(define (>>summary)
+ (format #t
+ (symbol->string
+ '#{
+AC_DEFUN([AUTOFRISK_SUMMARY],[
+if test ! "$~A" = "" ; then
+ p=" ***"
+ echo "$p"
+ echo "$p NOTE:"
+ echo "$p The following modules probably won't work:"
+ echo "$p $~A"
+ echo "$p They can be installed anyway, and will work if their"
+ echo "$p dependencies are installed later. Please see README."
+ echo "$p"
+fi
+])
+}#)
+ *pww* *pww*))
+
+(define (autofrisk . args)
+ (let ((file (if (null? args) "modules.af" (car args))))
+ (or (file-exists? file)
+ (error "could not find input file:" file))
+ (with-output-to-file (format #f "~A.m4" file)
+ (lambda ()
+ (>>checks (read-scheme-source-silently file))
+ (>>summary)))))
+
+(define main autofrisk)
+
+;; Local variables:
+;; eval: (put 'receive 'scheme-indent-function 2)
+;; End:
+
+;;; autofrisk ends here
diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm
new file mode 100644
index 000000000..d86f2f2bc
--- /dev/null
+++ b/module/scripts/compile.scm
@@ -0,0 +1,257 @@
+;;; Compile --- Command-line Guile Scheme compiler -*- coding: iso-8859-1 -*-
+
+;; Copyright 2005,2008-2011,2013-2015,2017-2018 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Ludovic Courtès <ludo@gnu.org>
+;;; Author: Andy Wingo <wingo@pobox.com>
+
+;;; Commentary:
+
+;; Usage: compile [ARGS]
+;;
+;; A command-line interface to the Guile compiler.
+
+;;; Code:
+
+(define-module (scripts compile)
+ #:use-module ((system base language) #:select (lookup-language))
+ #:use-module ((system base compile) #:select (compile-file))
+ #:use-module (system base target)
+ #:use-module (system base message)
+ #:use-module (system base optimize)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-13)
+ #:use-module (srfi srfi-37)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:export (compile))
+
+(define %summary "Compile a file.")
+
+
+(define (fail . messages)
+ (format (current-error-port) "error: ~{~a~}~%" messages)
+ (exit 1))
+
+(define %options
+ ;; Specifications of the command-line options.
+ (list (option '(#\h "help") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'help? #t result)))
+ (option '("version") #f #f
+ (lambda (opt name arg result)
+ (show-version)
+ (exit 0)))
+
+ (option '(#\L "load-path") #t #f
+ (lambda (opt name arg result)
+ (let ((load-path (assoc-ref result 'load-path)))
+ (alist-cons 'load-path (cons arg load-path)
+ result))))
+ (option '(#\o "output") #t #f
+ (lambda (opt name arg result)
+ (if (assoc-ref result 'output-file)
+ (fail "`-o' option cannot be specified more than once")
+ (alist-cons 'output-file arg result))))
+ (option '(#\x) #t #f
+ (lambda (opt name arg result)
+ (set! %load-extensions (cons arg %load-extensions))
+ result))
+
+ (option '(#\W "warn") #t #f
+ (lambda (opt name arg result)
+ (if (string=? arg "help")
+ (begin
+ (show-warning-help)
+ (exit 0))
+ (let ((warnings (assoc-ref result 'warnings)))
+ (alist-cons 'warnings
+ (cons (string->symbol arg) warnings)
+ (alist-delete 'warnings result))))))
+
+ (option '(#\O "optimize") #t #f
+ (lambda (opt name arg result)
+ (define (return val)
+ (alist-cons 'optimizations val result))
+ (define (return-option name val)
+ (let ((kw (symbol->keyword
+ (string->symbol (string-append name "?")))))
+ (unless (assq kw (available-optimizations))
+ (fail "Unknown optimization pass `~a'" name))
+ (return (list kw val))))
+ (cond
+ ((string=? arg "help")
+ (show-optimization-help)
+ (exit 0))
+ ((equal? arg "0") (return (optimizations-for-level 0)))
+ ((equal? arg "1") (return (optimizations-for-level 1)))
+ ((equal? arg "2") (return (optimizations-for-level 2)))
+ ((equal? arg "3") (return (optimizations-for-level 3)))
+ ((string-prefix? "no-" arg)
+ (return-option (substring arg 3) #f))
+ (else
+ (return-option arg #t)))))
+ (option '(#\f "from") #t #f
+ (lambda (opt name arg result)
+ (if (assoc-ref result 'from)
+ (fail "`--from' option cannot be specified more than once")
+ (alist-cons 'from (string->symbol arg) result))))
+ (option '(#\t "to") #t #f
+ (lambda (opt name arg result)
+ (if (assoc-ref result 'to)
+ (fail "`--to' option cannot be specified more than once")
+ (alist-cons 'to (string->symbol arg) result))))
+ (option '(#\T "target") #t #f
+ (lambda (opt name arg result)
+ (if (assoc-ref result 'target)
+ (fail "`--target' option cannot be specified more than once")
+ (alist-cons 'target arg result))))))
+
+(define (parse-args args)
+ "Parse argument list @var{args} and return an alist with all the relevant
+options."
+ (args-fold args %options
+ (lambda (opt name arg result)
+ (format (current-error-port) "~A: unrecognized option~%" name)
+ (exit 1))
+ (lambda (file result)
+ (let ((input-files (assoc-ref result 'input-files)))
+ (alist-cons 'input-files (cons file input-files)
+ result)))
+
+ ;; default option values
+ '((input-files)
+ (load-path)
+ (warnings unsupported-warning))))
+
+(define (show-version)
+ (format #t "compile (GNU Guile) ~A~%" (version))
+ (format #t "Copyright (C) 2018 Free Software Foundation, Inc.
+License LGPLv3+: GNU LGPL version 3 or later <http://gnu.org/licenses/lgpl.html>.
+This is free software: you are free to change and redistribute it.
+There is NO WARRANTY, to the extent permitted by law.~%"))
+
+(define (show-warning-help)
+ (format #t "The available warning types are:~%~%")
+ (for-each (lambda (wt)
+ (format #t " ~22A ~A~%"
+ (format #f "`~A'" (warning-type-name wt))
+ (warning-type-description wt)))
+ %warning-types)
+ (format #t "~%"))
+
+(define (show-optimization-help)
+ (format #t "The available optimizations are:~%~%")
+ (let lp ((options (available-optimizations)))
+ (match options
+ (() #t)
+ (((kw level) . options)
+ (let ((name (string-trim-right (symbol->string (keyword->symbol kw))
+ #\?)))
+ (format #t " -O~a~%" name)
+ (lp options)))))
+ (format #t "~%")
+ (format #t "To disable an optimization, prepend it with `no-', for example~%")
+ (format #t "`-Ono-cse.'~%~%")
+ (format #t "You may also specify optimization levels as `-O0', `-O1',~%")
+ (format #t "`-O2', or `-O3'. Currently `-O0' turns off all optimizations,~%")
+ (format #t "`-O1' turns on partial evaluation, and `-O2' and `-O3' turn on~%")
+ (format #t "everything. The default is equivalent to `-O2'.")
+ (format #t "~%"))
+
+
+(define (compile . args)
+ (let* ((options (parse-args args))
+ (help? (assoc-ref options 'help?))
+ (compile-opts `(#:warnings
+ ,(assoc-ref options 'warnings)
+ ,@(append-map
+ (lambda (opt)
+ (match opt
+ (('optimizations . opts) opts)
+ (_ '())))
+ options)))
+ (from (or (assoc-ref options 'from) 'scheme))
+ (to (or (assoc-ref options 'to) 'bytecode))
+ (target (or (assoc-ref options 'target) %host-type))
+ (input-files (assoc-ref options 'input-files))
+ (output-file (assoc-ref options 'output-file))
+ (load-path (assoc-ref options 'load-path)))
+ (if (or help? (null? input-files))
+ (begin
+ (format #t "Usage: compile [OPTION] FILE...
+Compile each Guile source file FILE into a Guile object.
+
+ -h, --help print this help message
+
+ -L, --load-path=DIR add DIR to the front of the module load path
+ -o, --output=OFILE write output to OFILE
+ -x EXTENSION add EXTENSION to the set of source file extensions
+
+ -W, --warn=WARNING emit warnings of type WARNING; use `--warn=help'
+ for a list of available warnings
+ -O, --optimize=OPT specify optimization passes to run; use `-Ohelp'
+ for a list of available optimizations
+
+ -f, --from=LANG specify a source language other than `scheme'
+ -t, --to=LANG specify a target language other than `bytecode'
+ -T, --target=TRIPLET produce bytecode for host TRIPLET
+
+Note that auto-compilation will be turned off.
+
+Report bugs to <~A>.~%"
+ %guile-bug-report-address)
+ (exit 0)))
+
+ ;; Load FROM and TO before we have changed the load path. That way, when
+ ;; cross-compiling Guile itself, we can be sure we're loading our own
+ ;; language modules and not those of the Guile being compiled, which may
+ ;; have incompatible .go files.
+ (lookup-language from)
+ (lookup-language to)
+
+ (set! %load-path (append load-path %load-path))
+ (set! %load-should-auto-compile #f)
+
+ (if (and output-file
+ (or (null? input-files)
+ (not (null? (cdr input-files)))))
+ (fail "`-o' option can only be specified "
+ "when compiling a single file"))
+
+ ;; Install a SIGINT handler. As a side effect, this gives unwind
+ ;; handlers an opportunity to run upon SIGINT; this includes that of
+ ;; 'call-with-output-file/atomic', called by 'compile-file', which
+ ;; removes the temporary output file.
+ (sigaction SIGINT
+ (lambda args
+ (fail "interrupted by the user")))
+
+ (for-each (lambda (file)
+ (format #t "wrote `~A'\n"
+ (with-fluids ((*current-warning-prefix* ""))
+ (with-target target
+ (lambda ()
+ (compile-file file
+ #:output-file output-file
+ #:from from
+ #:to to
+ #:opts compile-opts))))))
+ input-files)))
+
+(define main compile)
diff --git a/module/scripts/disassemble.scm b/module/scripts/disassemble.scm
new file mode 100644
index 000000000..426f87c59
--- /dev/null
+++ b/module/scripts/disassemble.scm
@@ -0,0 +1,38 @@
+;;; Disassemble --- Disassemble .go files into something human-readable
+
+;; Copyright 2005, 2008, 2009, 2011, 2012, 2013 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Ludovic Courtès <ludo@gnu.org>
+;;; Author: Andy Wingo <wingo@pobox.com>
+
+;;; Commentary:
+
+;; Usage: disassemble FILE...
+
+;;; Code:
+
+(define-module (scripts disassemble)
+ #:use-module (system vm disassembler)
+ #:export (disassemble))
+
+(define %summary "Disassemble a compiled .go file.")
+
+(define (disassemble . files)
+ (for-each disassemble-file files))
+
+(define main disassemble)
diff --git a/module/scripts/display-commentary.scm b/module/scripts/display-commentary.scm
new file mode 100644
index 000000000..81d7907af
--- /dev/null
+++ b/module/scripts/display-commentary.scm
@@ -0,0 +1,67 @@
+;;; display-commentary --- As advertized
+
+;; Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen
+
+;;; Commentary:
+
+;; Usage: display-commentary REF1 REF2 ...
+;;
+;; Display Commentary section from REF1, REF2 and so on.
+;; Each REF may be a filename or module name (list of symbols).
+;; In the latter case, a filename is computed by searching `%load-path'.
+
+;;; Code:
+
+(define-module (scripts display-commentary)
+ :use-module (ice-9 documentation)
+ :export (display-commentary))
+
+(define %summary "Display the Commentary section from a file or module.")
+
+(define (display-commentary-one file)
+ (format #t "~A commentary:\n~A" file (file-commentary file)))
+
+(define (module-name->filename-frag ls) ; todo: export or move
+ (let ((ls (map symbol->string ls)))
+ (let loop ((ls (cdr ls)) (acc (car ls)))
+ (if (null? ls)
+ acc
+ (loop (cdr ls) (string-append acc "/" (car ls)))))))
+
+(define (display-module-commentary module-name)
+ (cond ((%search-load-path (module-name->filename-frag module-name))
+ => (lambda (file)
+ (format #t "module ~A\n" module-name)
+ (display-commentary-one file)))))
+
+(define (display-commentary . refs)
+ (for-each (lambda (ref)
+ (cond ((string? ref)
+ (if (equal? 0 (string-index ref #\())
+ (display-module-commentary
+ (with-input-from-string ref read))
+ (display-commentary-one ref)))
+ ((list? ref)
+ (display-module-commentary ref))))
+ refs))
+
+(define main display-commentary)
+
+;;; display-commentary ends here
diff --git a/module/scripts/doc-snarf.scm b/module/scripts/doc-snarf.scm
new file mode 100644
index 000000000..fa3dfb312
--- /dev/null
+++ b/module/scripts/doc-snarf.scm
@@ -0,0 +1,439 @@
+;;; doc-snarf --- Extract documentation from source files
+
+;; Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Martin Grabmueller
+
+;;; 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.
+;; (maybe) Use in Guile build itself.
+
+(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 %summary "Snarf out documentation from a file.")
+
+(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
diff --git a/module/scripts/frisk.scm b/module/scripts/frisk.scm
new file mode 100644
index 000000000..a8f79232d
--- /dev/null
+++ b/module/scripts/frisk.scm
@@ -0,0 +1,290 @@
+;;; frisk --- Grok the module interfaces of a body of files
+
+;; Copyright (C) 2002, 2006, 2010, 2011 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: frisk [options] file ...
+;;
+;; Analyze FILE... module interfaces in aggregate (as a "body"),
+;; and display a summary. Modules that are `define-module'd are
+;; considered "internal" (and those not, "external"). When module X
+;; uses module Y, X is said to be "(a) downstream of" Y, and Y is
+;; "(an) upstream of" X.
+;;
+;; Normally, the summary displays external modules and their internal
+;; downstreams, as this is the usual question asked by a body. There
+;; are several options that modify this output.
+;;
+;; -u, --upstream show upstream edges
+;; -d, --downstream show downstream edges (default)
+;; -i, --internal show internal modules
+;; -x, --external show external modules (default)
+;;
+;; If given both `upstream' and `downstream' options ("frisk -ud"), the
+;; output is formatted: "C MODULE --- UP-LS --- DOWN-LS", where C is
+;; either `i' or `x', and each element of UP-LS and DOWN-LS is (TYPE
+;; MODULE-NAME ...).
+;;
+;; In all other cases, the "C MODULE" occupies its own line, and
+;; subsequent lines list the up- or downstream edges, respectively,
+;; indented by some non-zero amount of whitespace.
+;;
+;; Top-level `use-modules' (or `load' or 'primitive-load') forms in a
+;; file that do not follow a `define-module' result an edge where the
+;; downstream is the "default module", normally `(guile-user)'. This
+;; can be set to another value by using:
+;;
+;; -m, --default-module MOD set MOD as the default module
+
+;; Usage from a Scheme Program: (use-modules (scripts frisk))
+;;
+;; Module export list:
+;; (frisk . args)
+;; (make-frisker . options) => (lambda (files) ...) [see below]
+;; (mod-up-ls module) => upstream edges
+;; (mod-down-ls module) => downstream edges
+;; (mod-int? module) => is the module internal?
+;; (edge-type edge) => symbol: {regular,autoload,computed}
+;; (edge-up edge) => upstream module
+;; (edge-down edge) => downstream module
+;;
+;; OPTIONS is an alist. Recognized keys are:
+;; default-module
+;;
+;; `make-frisker' returns a procedure that takes a list of files, the
+;; FRISKER. FRISKER returns a closure, REPORT, that takes one of the
+;; keys:
+;; modules -- entire list of modules
+;; internal -- list of internal modules
+;; external -- list of external modules
+;; i-up -- list of modules upstream of internal modules
+;; x-up -- list of modules upstream of external modules
+;; i-down -- list of modules downstream of internal modules
+;; x-down -- list of modules downstream of external modules
+;; edges -- list of edges
+;; Note that `x-up' should always be null, since by (lack of!)
+;; definition, we only know external modules by reference.
+;;
+;; The module and edge objects managed by REPORT can be examined in
+;; detail by using the other (self-explanatory) procedures. Be careful
+;; not to confuse a freshly consed list of symbols, like `(a b c)' with
+;; the module `(a b c)'. If you want to find the module by that name,
+;; try: (cond ((member '(a b c) (REPORT 'modules)) => car)).
+
+;; TODO: Make "frisk -ud" output less ugly.
+;; Consider default module as internal; add option to invert.
+;; Support `edge-misc' data.
+
+;;; Code:
+
+(define-module (scripts frisk)
+ :autoload (ice-9 getopt-long) (getopt-long)
+ :use-module ((srfi srfi-1) :select (filter remove))
+ :export (frisk
+ make-frisker
+ mod-up-ls mod-down-ls mod-int?
+ edge-type edge-up edge-down))
+
+(define %include-in-guild-list #f)
+(define %summary "Show dependency information for a module.")
+
+(define *default-module* '(guile-user))
+
+(define (grok-proc default-module note-use!)
+ (lambda (filename)
+ (let* ((p (open-file filename "r"))
+ (next (lambda () (read p)))
+ (ferret (lambda (use) ;;; handle "((foo bar) :select ...)"
+ (let ((maybe (car use)))
+ (if (list? maybe)
+ maybe
+ use))))
+ (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)
+ (note-use! 'def module #f)
+ (let loop ((ls form))
+ (or (null? ls)
+ (case (car ls)
+ ((#:use-module :use-module)
+ (note-use! 'regular module (ferret (cadr ls)))
+ (loop (cddr ls)))
+ ((#:autoload :autoload)
+ (note-use! 'autoload module (cadr ls))
+ (loop (cdddr ls)))
+ (else (loop (cdr ls))))))))
+ ((use-modules)
+ (for-each (lambda (use)
+ (note-use! 'regular
+ (or curmod default-module)
+ (ferret use)))
+ (cdr form)))
+ ((load primitive-load)
+ (note-use! 'computed
+ (or curmod default-module)
+ (let ((file (cadr form)))
+ (if (string? file)
+ file
+ (format #f "[computed in ~A]"
+ filename))))))
+ (loop (next))))))))
+
+(define up-ls (make-object-property)) ; list
+(define dn-ls (make-object-property)) ; list
+(define int? (make-object-property)) ; defined via `define-module'
+
+(define mod-up-ls up-ls)
+(define mod-down-ls dn-ls)
+(define mod-int? int?)
+
+(define (i-or-x module)
+ (if (int? module) 'i 'x))
+
+(define edge-type (make-object-property)) ; symbol
+
+(define (make-edge type up down)
+ (let ((new (cons up down)))
+ (set! (edge-type new) type)
+ new))
+
+(define edge-up car)
+(define edge-down cdr)
+
+(define (up-ls+! m new) (set! (up-ls m) (cons new (up-ls m))))
+(define (dn-ls+! m new) (set! (dn-ls m) (cons new (dn-ls m))))
+
+(define (make-body alist)
+ (lambda (key)
+ (assq-ref alist key)))
+
+(define (scan default-module files)
+ (let* ((modules (list))
+ (edges (list))
+ (intern (lambda (module)
+ (cond ((member module modules) => car)
+ (else (set! (up-ls module) (list))
+ (set! (dn-ls module) (list))
+ (set! modules (cons module modules))
+ module))))
+ (grok (grok-proc default-module
+ (lambda (type d u)
+ (let ((d (intern d)))
+ (if (eq? type 'def)
+ (set! (int? d) #t)
+ (let* ((u (intern u))
+ (edge (make-edge type u d)))
+ (set! edges (cons edge edges))
+ (up-ls+! d edge)
+ (dn-ls+! u edge))))))))
+ (for-each grok files)
+ (make-body
+ `((modules . ,modules)
+ (internal . ,(filter int? modules))
+ (external . ,(remove int? modules))
+ (i-up . ,(filter int? (map edge-down edges)))
+ (x-up . ,(remove int? (map edge-down edges)))
+ (i-down . ,(filter int? (map edge-up edges)))
+ (x-down . ,(remove int? (map edge-up edges)))
+ (edges . ,edges)))))
+
+(define (make-frisker . options)
+ (let ((default-module (or (assq-ref options 'default-module)
+ *default-module*)))
+ (lambda (files)
+ (scan default-module files))))
+
+(define (dump-updown modules)
+ (for-each (lambda (m)
+ (format #t "~A ~A --- ~A --- ~A\n"
+ (i-or-x m) m
+ (map (lambda (edge)
+ (cons (edge-type edge)
+ (edge-up edge)))
+ (up-ls m))
+ (map (lambda (edge)
+ (cons (edge-type edge)
+ (edge-down edge)))
+ (dn-ls m))))
+ modules))
+
+(define (dump-up modules)
+ (for-each (lambda (m)
+ (format #t "~A ~A\n" (i-or-x m) m)
+ (for-each (lambda (edge)
+ (format #t "\t\t\t ~A\t~A\n"
+ (edge-type edge) (edge-up edge)))
+ (up-ls m)))
+ modules))
+
+(define (dump-down modules)
+ (for-each (lambda (m)
+ (format #t "~A ~A\n" (i-or-x m) m)
+ (for-each (lambda (edge)
+ (format #t "\t\t\t ~A\t~A\n"
+ (edge-type edge) (edge-down edge)))
+ (dn-ls m)))
+ modules))
+
+(define (frisk . args)
+ (let* ((parsed-opts (getopt-long
+ (cons "frisk" args) ;;; kludge
+ '((upstream (single-char #\u))
+ (downstream (single-char #\d))
+ (internal (single-char #\i))
+ (external (single-char #\x))
+ (default-module
+ (single-char #\m)
+ (value #t)))))
+ (=u (option-ref parsed-opts 'upstream #f))
+ (=d (option-ref parsed-opts 'downstream #f))
+ (=i (option-ref parsed-opts 'internal #f))
+ (=x (option-ref parsed-opts 'external #f))
+ (files (option-ref parsed-opts '() (list)))
+ (report ((make-frisker
+ `(default-module
+ . ,(option-ref parsed-opts 'default-module
+ *default-module*)))
+ files))
+ (modules (report 'modules))
+ (internal (report 'internal))
+ (external (report 'external))
+ (edges (report 'edges)))
+ (format #t "~A ~A, ~A ~A (~A ~A, ~A ~A), ~A ~A\n\n"
+ (length files) "files"
+ (length modules) "modules"
+ (length internal) "internal"
+ (length external) "external"
+ (length edges) "edges")
+ ((cond ((and =u =d) dump-updown)
+ (=u dump-up)
+ (else dump-down))
+ (cond ((and =i =x) modules)
+ (=i internal)
+ (else external)))))
+
+(define main frisk)
+
+;;; frisk ends here
diff --git a/module/scripts/generate-autoload.scm b/module/scripts/generate-autoload.scm
new file mode 100644
index 000000000..90f524b06
--- /dev/null
+++ b/module/scripts/generate-autoload.scm
@@ -0,0 +1,144 @@
+;;; generate-autoload --- Display define-module form with autoload info
+
+;; Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen
+
+;;; 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
+;; - in a `defmacro-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"))
+
+;;; Code:
+
+(define-module (scripts generate-autoload)
+ :export (generate-autoload))
+
+(define %include-in-guild-list #f)
+(define %summary "Generate #:autoload clauses for a module.")
+
+(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)))
+ ((and (list? form)
+ (< 3 (length form))
+ (eq? 'defmacro-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
diff --git a/module/scripts/help.scm b/module/scripts/help.scm
new file mode 100644
index 000000000..34400db3a
--- /dev/null
+++ b/module/scripts/help.scm
@@ -0,0 +1,188 @@
+;;; Help --- Show help on guild commands
+
+;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library 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
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free
+;;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; Usage: help
+;;
+;; Show help for Guild scripts.
+
+;;; Code:
+
+(define-module (scripts help)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 documentation)
+ #:use-module ((srfi srfi-1) #:select (fold append-map))
+ #:export (show-help show-summary show-usage main))
+
+(define %summary "Show a brief help message.")
+(define %synopsis "help\nhelp --all\nhelp COMMAND")
+(define %help "
+Show help on guild commands. With --all, show arcane incantations as
+well. With COMMAND, show more detailed help for a particular command.
+")
+
+
+(define (directory-files dir)
+ (if (and (file-exists? dir) (file-is-directory? dir))
+ (let ((dir-stream (opendir dir)))
+ (let loop ((new (readdir dir-stream))
+ (acc '()))
+ (if (eof-object? new)
+ (begin
+ (closedir dir-stream)
+ acc)
+ (loop (readdir dir-stream)
+ (if (or (string=? "." new) ; ignore
+ (string=? ".." new)) ; ignore
+ acc
+ (cons new acc))))))
+ '()))
+
+(define (strip-extensions path)
+ (or-map (lambda (ext)
+ (and
+ (string-suffix? ext path)
+ ;; We really can't be adding e.g. ChangeLog-2008 to the set
+ ;; of runnable scripts, just because "" is a valid
+ ;; extension, by default. So hack around that here.
+ (not (string-null? ext))
+ (substring path 0
+ (- (string-length path) (string-length ext)))))
+ (append %load-compiled-extensions %load-extensions)))
+
+(define (unique l)
+ (cond ((null? l) l)
+ ((null? (cdr l)) l)
+ ((equal? (car l) (cadr l)) (unique (cdr l)))
+ (else (cons (car l) (unique (cdr l))))))
+
+(define (find-submodules head)
+ (let ((shead (map symbol->string head)))
+ (unique
+ (sort
+ (append-map (lambda (path)
+ (fold (lambda (x rest)
+ (let ((stripped (strip-extensions x)))
+ (if stripped (cons stripped rest) rest)))
+ '()
+ (directory-files
+ (fold (lambda (x y) (in-vicinity y x)) path shead))))
+ %load-path)
+ string<?))))
+
+(define (list-commands all?)
+ (display "\
+Usage: guild COMMAND [ARGS]
+Run command-line scripts provided by GNU Guile and related programs.
+
+Commands:
+")
+
+ (for-each
+ (lambda (name)
+ (let* ((modname `(scripts ,(string->symbol name)))
+ (mod (resolve-module modname #:ensure #f))
+ (summary (and mod (and=> (module-variable mod '%summary)
+ variable-ref))))
+ (if (and mod
+ (or all?
+ (let ((v (module-variable mod '%include-in-guild-list)))
+ (if v (variable-ref v) #t))))
+ (if summary
+ (format #t " ~A ~23t~a\n" name summary)
+ (format #t " ~A\n" name)))))
+ (find-submodules '(scripts)))
+ (format #t "
+For help on a specific command, try \"guild help COMMAND\".
+
+Report guild bugs to ~a
+GNU Guile home page: <http://www.gnu.org/software/guile/>
+General help using GNU software: <http://www.gnu.org/gethelp/>
+For complete documentation, run: info '(guile)Using Guile Tools'
+" %guile-bug-report-address))
+
+(define (module-commentary mod)
+ (file-commentary
+ (%search-load-path (module-filename mod))))
+
+(define (module-command-name mod)
+ (symbol->string (car (last-pair (module-name mod)))))
+
+(define* (show-usage mod #:optional (port (current-output-port)))
+ (let ((usages (string-split
+ (let ((var (module-variable mod '%synopsis)))
+ (if var
+ (variable-ref var)
+ (string-append (module-command-name mod)
+ " OPTION...")))
+ #\newline)))
+ (display "Usage: guild " port)
+ (display (car usages))
+ (newline port)
+ (for-each (lambda (u)
+ (display " guild " port)
+ (display u port)
+ (newline port))
+ (cdr usages))))
+
+(define* (show-summary mod #:optional (port (current-output-port)))
+ (let ((var (module-variable mod '%summary)))
+ (if var
+ (begin
+ (display (variable-ref var) port)
+ (newline port)))))
+
+(define* (show-help mod #:optional (port (current-output-port)))
+ (show-usage mod port)
+ (show-summary mod port)
+ (cond
+ ((module-variable mod '%help)
+ => (lambda (var)
+ (display (variable-ref var) port)
+ (newline port)))
+ ((module-commentary mod)
+ => (lambda (commentary)
+ (newline port)
+ (display commentary port)))
+ (else
+ (format #t "No documentation found for command \"~a\".\n"
+ (module-command-name mod)))))
+
+(define %mod (current-module))
+(define (main . args)
+ (cond
+ ((null? args)
+ (list-commands #f))
+ ((or (equal? args '("--all")) (equal? args '("-a")))
+ (list-commands #t))
+ ((and (null? (cdr args)) (not (string-prefix? "-" (car args))))
+ ;; help for particular command
+ (let ((name (car args)))
+ (cond
+ ((resolve-module `(scripts ,(string->symbol name)) #:ensure #f)
+ => (lambda (mod)
+ (show-help mod)
+ (exit 0)))
+ (else
+ (format #t "No command named \"~a\".\n" name)
+ (exit 1)))))
+ (else
+ (show-help %mod (current-error-port))
+ (exit 1))))
diff --git a/module/scripts/lint.scm b/module/scripts/lint.scm
new file mode 100644
index 000000000..cea425ea9
--- /dev/null
+++ b/module/scripts/lint.scm
@@ -0,0 +1,318 @@
+;;; lint --- Preemptive checks for coding errors in Guile Scheme code
+
+;; Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Neil Jerram
+
+;;; Commentary:
+
+;; Usage: lint FILE1 FILE2 ...
+;;
+;; Perform various preemptive checks for coding errors in Guile Scheme
+;; code.
+;;
+;; Right now, there is only one check available, for unresolved free
+;; variables. The intention is that future lint-like checks will be
+;; implemented by adding to this script file.
+;;
+;; Unresolved free variables
+;; -------------------------
+;;
+;; Free variables are those whose definitions come from outside the
+;; module under investigation. In Guile, these definitions are
+;; imported from other modules using `#:use-module' forms.
+;;
+;; This tool scans the specified files for unresolved free variables -
+;; i.e. variables for which you may have forgotten the appropriate
+;; `#:use-module', or for which the module that is supposed to export
+;; them forgot to.
+;;
+;; It isn't guaranteed that the scan will find absolutely all such
+;; errors. Quoted (and quasiquoted) expressions are skipped, since
+;; they are most commonly used to describe constant data, not code, so
+;; code that is explicitly evaluated using `eval' will not be checked.
+;; For example, the `unresolved-var' in `(eval 'unresolved-var
+;; (current-module))' would be missed.
+;;
+;; False positives are also possible. Firstly, the tool doesn't
+;; understand all possible forms of implicit quoting; in particular,
+;; it doesn't detect and expand uses of macros. Secondly, it picks up
+;; explicit compatibility code like `(if (defined? 'x) (define y x))'.
+;; Thirdly, there are occasional oddities like `next-method'.
+;; However, the number of false positives for realistic code is
+;; hopefully small enough that they can be individually considered and
+;; ignored.
+;;
+;; Example
+;; -------
+;;
+;; Note: most of the unresolved variables found in this example are
+;; false positives, as you would hope. => scope for improvement.
+;;
+;; $ guild lint `guild`
+;; No unresolved free variables in PROGRAM
+;; No unresolved free variables in autofrisk
+;; No unresolved free variables in display-commentary
+;; Unresolved free variables in doc-snarf:
+;; doc-snarf-version
+;; No unresolved free variables in frisk
+;; No unresolved free variables in generate-autoload
+;; No unresolved free variables in lint
+;; No unresolved free variables in punify
+;; No unresolved free variables in read-scheme-source
+;; Unresolved free variables in snarf-check-and-output-texi:
+;; name
+;; pos
+;; line
+;; x
+;; rest
+;; ...
+;; do-argpos
+;; do-command
+;; do-args
+;; type
+;; num
+;; file
+;; do-arglist
+;; req
+;; opt
+;; var
+;; command
+;; do-directive
+;; s
+;; ?
+;; No unresolved free variables in use2dot
+
+;;; Code:
+
+(define-module (scripts lint)
+ #:use-module (ice-9 common-list)
+ #:use-module (ice-9 format)
+ #:export (lint))
+
+(define %include-in-guild-list #f)
+(define %summary "Check for bugs and style errors in a Scheme file.")
+
+(define (lint filename)
+ (let ((module-name (scan-file-for-module-name filename))
+ (free-vars (uniq (scan-file-for-free-variables filename))))
+ (let ((module (resolve-module module-name))
+ (all-resolved? #t))
+ (format #t "Resolved module: ~S\n" module)
+ (let loop ((free-vars free-vars))
+ (or (null? free-vars)
+ (begin
+ (catch #t
+ (lambda ()
+ (eval (car free-vars) module))
+ (lambda args
+ (if all-resolved?
+ (format #t
+ "Unresolved free variables in ~A:\n"
+ filename))
+ (write-char #\tab)
+ (write (car free-vars))
+ (newline)
+ (set! all-resolved? #f)))
+ (loop (cdr free-vars)))))
+ (if all-resolved?
+ (format #t
+ "No unresolved free variables in ~A\n"
+ filename)))))
+
+(define (scan-file-for-module-name filename)
+ (with-input-from-file filename
+ (lambda ()
+ (let loop ((x (read)))
+ (cond ((eof-object? x) #f)
+ ((and (pair? x)
+ (eq? (car x) 'define-module))
+ (cadr x))
+ (else (loop (read))))))))
+
+(define (scan-file-for-free-variables filename)
+ (with-input-from-file filename
+ (lambda ()
+ (let loop ((x (read)) (fvlists '()))
+ (if (eof-object? x)
+ (apply append fvlists)
+ (loop (read) (cons (detect-free-variables x '()) fvlists)))))))
+
+; guile> (detect-free-variables '(let ((a 1)) a) '())
+; ()
+; guile> (detect-free-variables '(let ((a 1)) b) '())
+; (b)
+; guile> (detect-free-variables '(let ((a 1) (b a)) b) '())
+; (a)
+; guile> (detect-free-variables '(let* ((a 1) (b a)) b) '())
+; ()
+; guile> (detect-free-variables '(define a 1) '())
+; ()
+; guile> (detect-free-variables '(define a b) '())
+; (b)
+; guile> (detect-free-variables '(define (a b c) b) '())
+; ()
+; guile> (detect-free-variables '(define (a b c) e) '())
+; (e)
+
+(define (detect-free-variables x locals)
+ ;; Given an expression @var{x} and a list @var{locals} of local
+ ;; variables (symbols) that are in scope for @var{x}, return a list
+ ;; of free variable symbols.
+ (cond ((symbol? x)
+ (if (memq x locals) '() (list x)))
+
+ ((pair? x)
+ (case (car x)
+ ((define-module define-generic quote quasiquote)
+ ;; No code of interest in these expressions.
+ '())
+
+ ((let letrec)
+ ;; Check for named let. If there is a name, transform the
+ ;; expression so that it looks like an unnamed let with
+ ;; the name as one of the bindings.
+ (if (symbol? (cadr x))
+ (set-cdr! x (cons (cons (list (cadr x) #f) (caddr x))
+ (cdddr x))))
+ ;; Unnamed let processing.
+ (let ((letrec? (eq? (car x) 'letrec))
+ (locals-for-let-body (append locals (map car (cadr x)))))
+ (append (apply append
+ (map (lambda (binding)
+ (detect-free-variables (cadr binding)
+ (if letrec?
+ locals-for-let-body
+ locals)))
+ (cadr x)))
+ (apply append
+ (map (lambda (bodyform)
+ (detect-free-variables bodyform
+ locals-for-let-body))
+ (cddr x))))))
+
+ ((let* and-let*)
+ ;; Handle bindings recursively.
+ (if (null? (cadr x))
+ (apply append
+ (map (lambda (bodyform)
+ (detect-free-variables bodyform locals))
+ (cddr x)))
+ (append (detect-free-variables (cadr (caadr x)) locals)
+ (detect-free-variables `(let* ,(cdadr x) ,@(cddr x))
+ (cons (caaadr x) locals)))))
+
+ ((define define-public define-macro)
+ (if (pair? (cadr x))
+ (begin
+ (set! locals (cons (caadr x) locals))
+ (detect-free-variables `(lambda ,(cdadr x) ,@(cddr x))
+ locals))
+ (begin
+ (set! locals (cons (cadr x) locals))
+ (detect-free-variables (caddr x) locals))))
+
+ ((lambda lambda*)
+ (let ((locals-for-lambda-body (let loop ((locals locals)
+ (args (cadr x)))
+ (cond ((null? args) locals)
+ ((pair? args)
+ (loop (cons (car args) locals)
+ (cdr args)))
+ (else
+ (cons args locals))))))
+ (apply append
+ (map (lambda (bodyform)
+ (detect-free-variables bodyform
+ locals-for-lambda-body))
+ (cddr x)))))
+
+ ((receive)
+ (let ((locals-for-receive-body (append locals (cadr x))))
+ (apply append
+ (detect-free-variables (caddr x) locals)
+ (map (lambda (bodyform)
+ (detect-free-variables bodyform
+ locals-for-receive-body))
+ (cdddr x)))))
+
+ ((define-method define*)
+ (let ((locals-for-method-body (let loop ((locals locals)
+ (args (cdadr x)))
+ (cond ((null? args) locals)
+ ((pair? args)
+ (loop (cons (if (pair? (car args))
+ (caar args)
+ (car args))
+ locals)
+ (cdr args)))
+ (else
+ (cons args locals))))))
+ (apply append
+ (map (lambda (bodyform)
+ (detect-free-variables bodyform
+ locals-for-method-body))
+ (cddr x)))))
+
+ ((define-class)
+ ;; Avoid picking up slot names at the start of slot
+ ;; definitions.
+ (apply append
+ (map (lambda (slot/option)
+ (detect-free-variables-noncar (if (pair? slot/option)
+ (cdr slot/option)
+ slot/option)
+ locals))
+ (cdddr x))))
+
+ ((case)
+ (apply append
+ (detect-free-variables (cadr x) locals)
+ (map (lambda (case)
+ (detect-free-variables (cdr case) locals))
+ (cddr x))))
+
+ ((unquote unquote-splicing else =>)
+ (detect-free-variables-noncar (cdr x) locals))
+
+ (else (append (detect-free-variables (car x) locals)
+ (detect-free-variables-noncar (cdr x) locals)))))
+
+ (else '())))
+
+(define (detect-free-variables-noncar x locals)
+ ;; Given an expression @var{x} and a list @var{locals} of local
+ ;; variables (symbols) that are in scope for @var{x}, return a list
+ ;; of free variable symbols.
+ (cond ((symbol? x)
+ (if (memq x locals) '() (list x)))
+
+ ((pair? x)
+ (case (car x)
+ ((=>)
+ (detect-free-variables-noncar (cdr x) locals))
+
+ (else (append (detect-free-variables (car x) locals)
+ (detect-free-variables-noncar (cdr x) locals)))))
+
+ (else '())))
+
+(define (main . files)
+ (for-each lint files))
+
+;;; lint ends here
diff --git a/module/scripts/list.scm b/module/scripts/list.scm
new file mode 100644
index 000000000..66116ce5b
--- /dev/null
+++ b/module/scripts/list.scm
@@ -0,0 +1,91 @@
+;;; List --- List scripts that can be invoked by guild -*- coding: iso-8859-1 -*-
+
+;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library 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
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free
+;;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; Usage: list
+;;
+;; List scripts that can be invoked by guild.
+
+;;; Code:
+
+(define-module (scripts list)
+ #:use-module (srfi srfi-1)
+ #:export (list-scripts))
+
+(define %include-in-guild-list #f)
+(define %summary "An alias for \"help\".")
+
+
+(define (directory-files dir)
+ (if (and (file-exists? dir) (file-is-directory? dir))
+ (let ((dir-stream (opendir dir)))
+ (let loop ((new (readdir dir-stream))
+ (acc '()))
+ (if (eof-object? new)
+ (begin
+ (closedir dir-stream)
+ acc)
+ (loop (readdir dir-stream)
+ (if (or (string=? "." new) ; ignore
+ (string=? ".." new)) ; ignore
+ acc
+ (cons new acc))))))
+ '()))
+
+(define (strip-extensions path)
+ (or-map (lambda (ext)
+ (and
+ (string-suffix? ext path)
+ ;; We really can't be adding e.g. ChangeLog-2008 to the set
+ ;; of runnable scripts, just because "" is a valid
+ ;; extension, by default. So hack around that here.
+ (not (string-null? ext))
+ (substring path 0
+ (- (string-length path) (string-length ext)))))
+ (append %load-compiled-extensions %load-extensions)))
+
+(define (unique l)
+ (cond ((null? l) l)
+ ((null? (cdr l)) l)
+ ((equal? (car l) (cadr l)) (unique (cdr l)))
+ (else (cons (car l) (unique (cdr l))))))
+
+(define (find-submodules head)
+ (let ((shead (map symbol->string head)))
+ (unique
+ (sort
+ (append-map (lambda (path)
+ (fold (lambda (x rest)
+ (let ((stripped (strip-extensions x)))
+ (if stripped (cons stripped rest) rest)))
+ '()
+ (directory-files
+ (fold (lambda (x y) (in-vicinity y x)) path shead))))
+ %load-path)
+ string<?))))
+
+(define (list-scripts . args)
+ (for-each (lambda (x)
+ ;; would be nice to show a summary.
+ (format #t "~A\n" x))
+ (find-submodules '(scripts))))
+
+(define (main . args)
+ (apply (@@ (scripts help) main) args))
diff --git a/module/scripts/punify.scm b/module/scripts/punify.scm
new file mode 100644
index 000000000..6b33ac5ee
--- /dev/null
+++ b/module/scripts/punify.scm
@@ -0,0 +1,87 @@
+;;; punify --- Display Scheme code w/o unnecessary comments / whitespace
+
+;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen
+
+;;; 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
+;; 89 384 3031 ./punify
+;; 0 42 920
+;;
+;; TODO: Read from stdin.
+;; Handle vectors.
+;; Identifier punification.
+
+;;; Code:
+
+(define-module (scripts punify)
+ :export (punify))
+
+(define %include-in-guild-list #f)
+(define %summary "Strip comments and whitespace from a Scheme file.")
+
+(define (write-punily form)
+ (cond ((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?))))))
+ ((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 (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
diff --git a/module/scripts/read-rfc822.scm b/module/scripts/read-rfc822.scm
new file mode 100644
index 000000000..08f3fb9a1
--- /dev/null
+++ b/module/scripts/read-rfc822.scm
@@ -0,0 +1,131 @@
+;;; read-rfc822 --- Validate RFC822 file by displaying it to stdout
+
+;; Copyright (C) 2002, 2004, 2006, 2011 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: read-rfc822 FILE
+;;
+;; Read FILE, assumed to be in RFC822 format, and display it to stdout.
+;; This is not very interesting, admittedly.
+;;
+;; For Scheme programming, this module exports two procs:
+;; (read-rfc822 . args) ; only first arg used
+;; (read-rfc822-silently port)
+;;
+;; Parse FILE (a string) or PORT, respectively, and return a query proc that
+;; takes a symbol COMP, and returns the message component COMP. Supported
+;; values for COMP (and the associated query return values) are:
+;; from -- #f (reserved for future mbox support)
+;; headers -- alist of (HEADER-SYMBOL . "VALUE-STRING") pairs, in order
+;; body -- rest of the mail message, a string
+;; body-lines -- rest of the mail message, as a list of lines
+;; Any other query results in a "bad component" error.
+;;
+;; TODO: Add "-m" option (mbox support).
+
+;;; Code:
+
+(define-module (scripts read-rfc822)
+ :use-module (ice-9 regex)
+ :use-module (ice-9 rdelim)
+ :autoload (srfi srfi-13) (string-join)
+ :export (read-rfc822 read-rfc822-silently))
+
+(define %include-in-guild-list #f)
+(define %summary "Validate an RFC822-style file.")
+
+(define from-line-rx (make-regexp "^From "))
+(define header-name-rx (make-regexp "^([^:]+):[ \t]*"))
+(define header-cont-rx (make-regexp "^[ \t]+"))
+
+(define option #f) ; for future "-m"
+
+(define (drain-message port)
+ (let loop ((line (read-line port)) (acc '()))
+ (cond ((eof-object? line)
+ (reverse acc))
+ ((and option (regexp-exec from-line-rx line))
+ (for-each (lambda (c)
+ (unread-char c port))
+ (cons #\newline
+ (reverse (string->list line))))
+ (reverse acc))
+ (else
+ (loop (read-line port) (cons line acc))))))
+
+(define (parse-message port)
+ (let* ((from (and option
+ (match:suffix (regexp-exec from-line-rx
+ (read-line port)))))
+ (body-lines #f)
+ (body #f)
+ (headers '())
+ (add-header! (lambda (reversed-hlines)
+ (let* ((hlines (reverse reversed-hlines))
+ (first (car hlines))
+ (m (regexp-exec header-name-rx first))
+ (name (string->symbol (match:substring m 1)))
+ (data (string-join
+ (cons (substring first (match:end m))
+ (cdr hlines))
+ " ")))
+ (set! headers (acons name data headers))))))
+ ;; "From " is only one line
+ (let loop ((line (read-line port)) (current-header #f))
+ (cond ((string-null? line)
+ (and current-header (add-header! current-header))
+ (set! body-lines (drain-message port)))
+ ((regexp-exec header-cont-rx line)
+ => (lambda (m)
+ (loop (read-line port)
+ (cons (match:suffix m) current-header))))
+ (else
+ (and current-header (add-header! current-header))
+ (loop (read-line port) (list line)))))
+ (set! headers (reverse headers))
+ (lambda (component)
+ (case component
+ ((from) from)
+ ((body-lines) body-lines)
+ ((headers) headers)
+ ((body) (or body
+ (begin (set! body (string-join body-lines "\n" 'suffix))
+ body)))
+ (else (error "bad component:" component))))))
+
+(define (read-rfc822-silently port)
+ (parse-message port))
+
+(define (display-rfc822 parse)
+ (cond ((parse 'from) => (lambda (from) (format #t "From ~A\n" from))))
+ (for-each (lambda (header)
+ (format #t "~A: ~A\n" (car header) (cdr header)))
+ (parse 'headers))
+ (format #t "\n~A" (parse 'body)))
+
+(define (read-rfc822 . args)
+ (let ((parse (read-rfc822-silently (open-file (car args) OPEN_READ))))
+ (display-rfc822 parse))
+ #t)
+
+(define main read-rfc822)
+
+;;; read-rfc822 ends here
diff --git a/module/scripts/read-scheme-source.scm b/module/scripts/read-scheme-source.scm
new file mode 100644
index 000000000..1bca6a4c4
--- /dev/null
+++ b/module/scripts/read-scheme-source.scm
@@ -0,0 +1,282 @@
+;;; read-scheme-source --- Read a file, recognizing scheme forms and comments
+
+;; Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen
+
+;;; Commentary:
+
+;; Usage: read-scheme-source FILE1 FILE2 ...
+;;
+;; This program parses each FILE and writes to stdout sexps that describe the
+;; top-level structures of the file: scheme forms, single-line comments, and
+;; hash-bang comments. You can further process these (to associate comments
+;; w/ scheme forms as a kind of documentation, for example).
+;;
+;; The output sexps have one of these forms:
+;;
+;; (quote (filename FILENAME))
+;;
+;; (quote (comment :leading-semicolons N
+;; :text LINE))
+;;
+;; (quote (whitespace :text LINE))
+;;
+;; (quote (hash-bang-comment :line LINUM
+;; :line-count N
+;; :text-list (LINE1 LINE2 ...)))
+;;
+;; (quote (following-form-properties :line LINUM
+;; :line-count N)
+;; :type TYPE
+;; :signature SIGNATURE
+;; :std-int-doc DOCSTRING))
+;;
+;; SEXP
+;;
+;; The first four are straightforward (both FILENAME and LINE are strings sans
+;; newline, while LINUM and N are integers). The last two always go together,
+;; in that order. SEXP is scheme code processed only by `read' and then
+;; `write'.
+;;
+;; The :type field may be omitted if the form is not recognized. Otherwise,
+;; TYPE may be one of: procedure, alias, define-module, variable.
+;;
+;; The :signature field may be omitted if the form is not a procedure.
+;; Otherwise, SIGNATURE is a list showing the procedure's signature.
+;;
+;; If the type is `procedure' and the form has a standard internal docstring
+;; (first body form a string), that is extracted in full -- including any
+;; embedded newlines -- and recorded by field :std-int-doc.
+;;
+;;
+;; Usage from a program: The output list of sexps can be retrieved by scheme
+;; programs w/o having to capture stdout, like so:
+;;
+;; (use-modules (scripts read-scheme-source))
+;; (define source-forms (read-scheme-source-silently "FILE1" "FILE2" ...))
+;;
+;; There are also two convenience procs exported for use by Scheme programs:
+;;
+;; (clump FORMS) --- filter FORMS combining contiguous comment forms that
+;; have the same number of leading semicolons.
+;;
+;; (quoted? SYM FORM) --- see if FORM looks like: "(quote (SYM ...))", parse
+;; the ":tags", and return alist of (TAG . VAL) elems.
+;;
+;; TODO: Add option "--clump-comments", maybe w/ different clumping styles.
+;; Make `annotate!' extensible.
+
+;;; Code:
+
+(define-module (scripts read-scheme-source)
+ :use-module (ice-9 rdelim)
+ :export (read-scheme-source
+ read-scheme-source-silently
+ quoted?
+ clump))
+
+(define %include-in-guild-list #f)
+(define %summary "Print a parsed representation of a Scheme file.")
+
+;; Try to figure out what FORM is and its various attributes.
+;; Call proc NOTE! with key (a symbol) and value.
+;;
+(define (annotate! form note!)
+ (cond ((and (list? form)
+ (< 2 (length form))
+ (eq? 'define (car form))
+ (pair? (cadr form))
+ (symbol? (caadr form)))
+ (note! ':type 'procedure)
+ (note! ':signature (cadr form))
+ (and (< 3 (length form))
+ (string? (caddr form))
+ (note! ':std-int-doc (caddr form))))
+ ((and (list? form)
+ (< 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))))
+ (note! ':type 'procedure)
+ (note! ':signature (cons (cadr form) (cadr (caddr form))))
+ (note! ':std-int-doc (caddr (caddr form))))
+ ((and (list? form)
+ (= 3 (length form))
+ (eq? 'define (car form))
+ (symbol? (cadr form))
+ (symbol? (caddr form)))
+ (note! ':type 'alias))
+ ((and (list? form)
+ (eq? 'define-module (car form)))
+ (note! ':type 'define-module))
+ ;; Add other types here.
+ (else (note! ':type 'variable))))
+
+;; Process FILE, calling NB! on parsed top-level elements.
+;; Recognized: #!-!# and regular comments in addition to normal forms.
+;;
+(define (process file nb!)
+ (nb! `'(filename ,file))
+ (let ((hash-bang-rx (make-regexp "^#!"))
+ (bang-hash-rx (make-regexp "^!#"))
+ (all-comment-rx (make-regexp "^[ \t]*(;+)"))
+ (all-whitespace-rx (make-regexp "^[ \t]*$"))
+ (p (open-input-file file)))
+ (let loop ((n (1+ (port-line p))) (line (read-line p)))
+ (or (not n)
+ (eof-object? line)
+ (begin
+ (cond ((regexp-exec hash-bang-rx line)
+ (let loop ((line (read-line p))
+ (text (list line)))
+ (if (or (eof-object? line)
+ (regexp-exec bang-hash-rx line))
+ (nb! `'(hash-bang-comment
+ :line ,n
+ :line-count ,(1+ (length text))
+ :text-list ,(reverse
+ (cons line text))))
+ (loop (read-line p)
+ (cons line text)))))
+ ((regexp-exec all-whitespace-rx line)
+ (nb! `'(whitespace :text ,line)))
+ ((regexp-exec all-comment-rx line)
+ => (lambda (m)
+ (nb! `'(comment
+ :leading-semicolons
+ ,(let ((m1 (vector-ref m 1)))
+ (- (cdr m1) (car m1)))
+ :text ,line))))
+ (else
+ (unread-string line p)
+ (let* ((form (read p))
+ (count (- (port-line p) n))
+ (props (let* ((props '())
+ (prop+ (lambda args
+ (set! props
+ (append props args)))))
+ (annotate! form prop+)
+ props)))
+ (or (= count 1) ; ugh
+ (begin
+ (read-line p)
+ (set! count (1+ count))))
+ (nb! `'(following-form-properties
+ :line ,n
+ :line-count ,count
+ ,@props))
+ (nb! form))))
+ (loop (1+ (port-line p)) (read-line p)))))))
+
+;;; entry points
+
+(define (read-scheme-source-silently . files)
+ "See commentary in module (scripts read-scheme-source)."
+ (let* ((res '()))
+ (for-each (lambda (file)
+ (process file (lambda (e) (set! res (cons e res)))))
+ files)
+ (reverse res)))
+
+(define (read-scheme-source . files)
+ "See commentary in module (scripts read-scheme-source)."
+ (for-each (lambda (file)
+ (process file (lambda (e) (write e) (newline))))
+ files))
+
+;; Recognize: (quote (SYM :TAG1 VAL1 :TAG2 VAL2 ...))
+;; and return alist: ((TAG1 . VAL1) (TAG2 . VAL2) ...)
+;; where the tags are symbols.
+;;
+(define (quoted? sym form)
+ (and (list? form)
+ (= 2 (length form))
+ (eq? 'quote (car form))
+ (let ((inside (cadr form)))
+ (and (list? inside)
+ (< 0 (length inside))
+ (eq? sym (car inside))
+ (let loop ((ls (cdr inside)) (alist '()))
+ (if (null? ls)
+ alist ; retval
+ (let ((first (car ls)))
+ (or (symbol? first)
+ (error "bad list!"))
+ (loop (cddr ls)
+ (acons (string->symbol
+ (substring (symbol->string first) 1))
+ (cadr ls)
+ alist)))))))))
+
+;; Filter FORMS, combining contiguous comment forms that have the same number
+;; of leading semicolons. Do not include in them whitespace lines.
+;; Whitespace lines outside of such comment groupings are ignored, as are
+;; hash-bang comments. All other forms are passed through unchanged.
+;;
+(define (clump forms)
+ (let loop ((forms forms) (acc '()) (pass-this-one-through? #f))
+ (if (null? forms)
+ (reverse acc) ; retval
+ (let ((form (car forms)))
+ (cond (pass-this-one-through?
+ (loop (cdr forms) (cons form acc) #f))
+ ((quoted? 'following-form-properties form)
+ (loop (cdr forms) (cons form acc) #t))
+ ((quoted? 'whitespace form) ;;; ignore
+ (loop (cdr forms) acc #f))
+ ((quoted? 'hash-bang-comment form) ;;; ignore for now
+ (loop (cdr forms) acc #f))
+ ((quoted? 'comment form)
+ => (lambda (alist)
+ (let cloop ((inner-forms (cdr forms))
+ (level (assq-ref alist 'leading-semicolons))
+ (text (list (assq-ref alist 'text))))
+ (let ((up (lambda ()
+ (loop inner-forms
+ (cons (cons level (reverse text))
+ acc)
+ #f))))
+ (if (null? inner-forms)
+ (up)
+ (let ((inner-form (car inner-forms)))
+ (cond ((quoted? 'comment inner-form)
+ => (lambda (inner-alist)
+ (let ((new-level
+ (assq-ref
+ inner-alist
+ 'leading-semicolons)))
+ (if (= new-level level)
+ (cloop (cdr inner-forms)
+ level
+ (cons (assq-ref
+ inner-alist
+ 'text)
+ text))
+ (up)))))
+ (else (up)))))))))
+ (else (loop (cdr forms) (cons form acc) #f)))))))
+
+;;; script entry point
+
+(define main read-scheme-source)
+
+;;; read-scheme-source ends here
diff --git a/module/scripts/read-text-outline.scm b/module/scripts/read-text-outline.scm
new file mode 100644
index 000000000..d0933bb0b
--- /dev/null
+++ b/module/scripts/read-text-outline.scm
@@ -0,0 +1,253 @@
+;;; read-text-outline --- Read a text outline and display it as a sexp
+
+;; Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: read-text-outline OUTLINE
+;;
+;; Scan OUTLINE file and display a list of trees, the structure of
+;; each reflecting the "levels" in OUTLINE. The recognized outline
+;; format (used to indicate outline headings) is zero or more pairs of
+;; leading spaces followed by "-". Something like:
+;;
+;; - a 0
+;; - b 1
+;; - c 2
+;; - d 1
+;; - e 0
+;; - f 1
+;; - g 2
+;; - h 1
+;;
+;; In this example the levels are shown to the right. The output for
+;; such a file would be the single line:
+;;
+;; (("a" ("b" "c") "d") ("e" ("f" "g") "h"))
+;;
+;; Basically, anything at the beginning of a list is a parent, and the
+;; remaining elements of that list are its children.
+;;
+;;
+;; Usage from a Scheme program: These two procs are exported:
+;;
+;; (read-text-outline . args) ; only first arg is used
+;; (read-text-outline-silently port)
+;; (make-text-outline-reader re specs)
+;;
+;; `make-text-outline-reader' returns a proc that reads from PORT and
+;; returns a list of trees (similar to `read-text-outline-silently').
+;;
+;; RE is a regular expression (string) that is used to identify a header
+;; line of the outline (as opposed to a whitespace line or intervening
+;; text). RE must begin w/ a sub-expression to match the "level prefix"
+;; of the line. You can use `level-submatch-number' in SPECS (explained
+;; below) to specify a number other than 1, the default.
+;;
+;; Normally, the level of the line is taken directly as the length of
+;; its level prefix. This often results in adjacent levels not mapping
+;; to adjacent numbers, which confuses the tree-building portion of the
+;; program, which expects top-level to be 0, first sub-level to be 1,
+;; etc. You can use `level-substring-divisor' or `compute-level' in
+;; SPECS to specify a constant scaling factor or specify a completely
+;; alternative procedure, respectively.
+;;
+;; SPECS is an alist which may contain the following key/value pairs:
+;;
+;; - level-submatch-number NUMBER
+;; - level-substring-divisor NUMBER
+;; - compute-level PROC
+;; - body-submatch-number NUMBER
+;; - extra-fields ((FIELD-1 . SUBMATCH-1) (FIELD-2 . SUBMATCH-2) ...)
+;;
+;; The PROC value associated with key `compute-level' should take a
+;; Scheme match structure (as returned by `regexp-exec') and return a
+;; number, the normalized level for that line. If this is specified,
+;; it takes precedence over other level-computation methods.
+;;
+;; Use `body-submatch-number' if RE specifies the whole body, or if you
+;; want to make use of the extra fields parsing. The `extra-fields'
+;; value is a sub-alist, whose keys name additional fields that are to
+;; be recognized. These fields along with `level' are set as object
+;; properties of the final string ("body") that is consed into the tree.
+;; If a field name ends in "?" the field value is set to be #t if there
+;; is a match and the result is not an empty string, and #f otherwise.
+;;
+;;
+;; Bugs and caveats:
+;;
+;; (1) Only the first file specified on the command line is scanned.
+;; (2) TAB characters at the beginnings of lines are not recognized.
+;; (3) Outlines that "skip" levels signal an error. In other words,
+;; this will fail:
+;;
+;; - a 0
+;; - b 1
+;; - c 3 <-- skipped 2 -- error!
+;; - d 1
+;;
+;;
+;; TODO: Determine what's the right thing to do for skips.
+;; Handle TABs.
+;; Make line format customizable via longopts.
+
+;;; Code:
+
+(define-module (scripts read-text-outline)
+ :export (read-text-outline
+ read-text-outline-silently
+ make-text-outline-reader)
+ :use-module (ice-9 regex)
+ :autoload (ice-9 rdelim) (read-line)
+ :autoload (ice-9 getopt-long) (getopt-long))
+
+(define %include-in-guild-list #f)
+(define %summary "Convert textual outlines to s-expressions.")
+
+(define (?? symbol)
+ (let ((name (symbol->string symbol)))
+ (string=? "?" (substring name (1- (string-length name))))))
+
+(define (msub n)
+ (lambda (m)
+ (match:substring m n)))
+
+(define (??-predicates pair)
+ (cons (car pair)
+ (if (?? (car pair))
+ (lambda (m)
+ (not (string=? "" (match:substring m (cdr pair)))))
+ (msub (cdr pair)))))
+
+(define (make-line-parser re specs)
+ (let* ((rx (let ((fc (substring re 0 1)))
+ (make-regexp (if (string=? "^" fc)
+ re
+ (string-append "^" re)))))
+ (check (lambda (key)
+ (assq-ref specs key)))
+ (level-substring (msub (or (check 'level-submatch-number) 1)))
+ (extract-level (cond ((check 'compute-level)
+ => (lambda (proc)
+ (lambda (m)
+ (proc m))))
+ ((check 'level-substring-divisor)
+ => (lambda (n)
+ (lambda (m)
+ (/ (string-length (level-substring m))
+ n))))
+ (else
+ (lambda (m)
+ (string-length (level-substring m))))))
+ (extract-body (cond ((check 'body-submatch-number)
+ => msub)
+ (else
+ (lambda (m) (match:suffix m)))))
+ (misc-props! (cond ((check 'extra-fields)
+ => (lambda (alist)
+ (let ((new (map ??-predicates alist)))
+ (lambda (obj m)
+ (for-each
+ (lambda (pair)
+ (set-object-property!
+ obj (car pair)
+ ((cdr pair) m)))
+ new)))))
+ (else
+ (lambda (obj m) #t)))))
+ ;; retval
+ (lambda (line)
+ (cond ((regexp-exec rx line)
+ => (lambda (m)
+ (let ((level (extract-level m))
+ (body (extract-body m)))
+ (set-object-property! body 'level level)
+ (misc-props! body m)
+ body)))
+ (else #f)))))
+
+(define (make-text-outline-reader re specs)
+ (let ((parse-line (make-line-parser re specs)))
+ ;; retval
+ (lambda (port)
+ (let* ((all '(start))
+ (pchain (list))) ; parents chain
+ (let loop ((line (read-line port))
+ (prev-level -1) ; how this relates to the first input
+ ; level determines whether or not we
+ ; start in "sibling" or "child" mode.
+ ; in the end, `start' is ignored and
+ ; it's much easier to ignore parents
+ ; than siblings (sometimes). this is
+ ; not to encourage ignorance, however.
+ (tp all)) ; tail pointer
+ (or (eof-object? line)
+ (cond ((parse-line line)
+ => (lambda (w)
+ (let* ((words (list w))
+ (level (object-property w 'level))
+ (diff (- level prev-level)))
+ (cond
+
+ ;; sibling
+ ((zero? diff)
+ ;; just extend the chain
+ (set-cdr! tp words))
+
+ ;; child
+ ((positive? diff)
+ (or (= 1 diff)
+ (error "unhandled diff not 1:" diff line))
+ ;; parent may be contacted by uncle later (kids
+ ;; these days!) so save its level
+ (set-object-property! tp 'level prev-level)
+ (set! pchain (cons tp pchain))
+ ;; "push down" car into hierarchy
+ (set-car! tp (cons (car tp) words)))
+
+ ;; uncle
+ ((negative? diff)
+ ;; prune back to where levels match
+ (do ((p pchain (cdr p)))
+ ((= level (object-property (car p) 'level))
+ (set! pchain p)))
+ ;; resume at this level
+ (set-cdr! (car pchain) words)
+ (set! pchain (cdr pchain))))
+
+ (loop (read-line port) level words))))
+ (else (loop (read-line port) prev-level tp)))))
+ (set! all (car all))
+ (if (eq? 'start all)
+ '() ; wasteland
+ (cdr all))))))
+
+(define read-text-outline-silently
+ (make-text-outline-reader "(([ ][ ])*)- *"
+ '((level-substring-divisor . 2))))
+
+(define (read-text-outline . args)
+ (write (read-text-outline-silently (open-file (car args) "r")))
+ (newline)
+ #t) ; exit val
+
+(define main read-text-outline)
+
+;;; read-text-outline ends here
diff --git a/module/scripts/scan-api.scm b/module/scripts/scan-api.scm
new file mode 100644
index 000000000..86d07fc3e
--- /dev/null
+++ b/module/scripts/scan-api.scm
@@ -0,0 +1,223 @@
+;;; scan-api --- Scan and group interpreter and libguile interface elements
+
+;; Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: scan-api GUILE SOFILE [GROUPINGS ...]
+;;
+;; Invoke GUILE, an executable guile interpreter, and use nm(1) on SOFILE, a
+;; shared-object library, to determine available interface elements, and
+;; display them to stdout as an alist:
+;;
+;; ((meta ...) (interface ...))
+;;
+;; The meta fields are `GUILE_LOAD_PATH', `LTDL_LIBRARY_PATH', `guile'
+;; `libguileinterface', `sofile' and `groups'. The interface elements are in
+;; turn sub-alists w/ keys `groups' and `scan-data'. Interface elements
+;; initially belong in one of two groups `Scheme' or `C' (but not both --
+;; signal error if that happens).
+;;
+;; Optional GROUPINGS ... are files each containing a single "grouping
+;; definition" alist with each entry of the form:
+;;
+;; (NAME (description "DESCRIPTION") (members SYM...))
+;;
+;; All of the SYM... should be proper subsets of the interface. In addition
+;; to `description' and `members' forms, the entry may optionally include:
+;;
+;; (grok USE-MODULES (lambda (x) CODE))
+;;
+;; where CODE implements a group-membership predicate to be applied to `x', a
+;; symbol. [When evaluated, CODE can assume (use-modules MODULE) has been
+;; executed where MODULE is an element of USE-MODULES, a list. [NOT YET
+;; IMPLEMENTED!]]
+;;
+;; Currently, there are two convenience predicates that operate on `x':
+;; (in-group? x GROUP)
+;; (name-prefix? x PREFIX)
+;;
+;; TODO: Allow for concurrent Scheme/C membership.
+;; Completely separate reporting.
+
+;;; Code:
+
+(define-module (scripts scan-api)
+ :use-module (ice-9 popen)
+ :use-module (ice-9 rdelim)
+ :use-module (ice-9 regex)
+ :export (scan-api))
+
+(define %include-in-guild-list #f)
+(define %summary "Generate an API description for a Guile extension.")
+
+(define put set-object-property!)
+(define get object-property)
+
+(define (add-props object . args)
+ (let loop ((args args))
+ (if (null? args)
+ object ; retval
+ (let ((key (car args))
+ (value (cadr args)))
+ (put object key value)
+ (loop (cddr args))))))
+
+(define (scan re command match)
+ (let ((rx (make-regexp re))
+ (port (open-pipe command OPEN_READ)))
+ (let loop ((line (read-line port)))
+ (or (eof-object? line)
+ (begin
+ (cond ((regexp-exec rx line) => match))
+ (loop (read-line port)))))))
+
+(define (scan-Scheme! ht guile)
+ (scan "^.guile.+: ([^ \t]+)([ \t]+(.+))*$"
+ (format #f "~A -c '~S ~S'"
+ guile
+ '(use-modules (ice-9 session))
+ '(apropos "."))
+ (lambda (m)
+ (let ((x (string->symbol (match:substring m 1))))
+ (put x 'Scheme (or (match:substring m 3)
+ ""))
+ (hashq-set! ht x #t)))))
+
+(define (scan-C! ht sofile)
+ (scan "^[0-9a-fA-F]+ ([B-TV-Z]) (.+)$"
+ (format #f "nm ~A" sofile)
+ (lambda (m)
+ (let ((x (string->symbol (match:substring m 2))))
+ (put x 'C (string->symbol (match:substring m 1)))
+ (and (hashq-get-handle ht x)
+ (error "both Scheme and C:" x))
+ (hashq-set! ht x #t)))))
+
+(define THIS-MODULE (current-module))
+
+(define (in-group? x group)
+ (memq group (get x 'groups)))
+
+(define (name-prefix? x prefix)
+ (string-match (string-append "^" prefix) (symbol->string x)))
+
+(define (add-group-name! x name)
+ (put x 'groups (cons name (get x 'groups))))
+
+(define (make-grok-proc name form)
+ (let* ((predicate? (eval form THIS-MODULE))
+ (p (lambda (x)
+ (and (predicate? x)
+ (add-group-name! x name)))))
+ (put p 'name name)
+ p))
+
+(define (make-members-proc name members)
+ (let ((p (lambda (x)
+ (and (memq x members)
+ (add-group-name! x name)))))
+ (put p 'name name)
+ p))
+
+(define (make-grouper files) ; \/^^^o/ . o
+ (let ((hook (make-hook 1))) ; /\____\
+ (for-each
+ (lambda (file)
+ (for-each
+ (lambda (gdef)
+ (let ((name (car gdef))
+ (members (assq-ref gdef 'members))
+ (grok (assq-ref gdef 'grok)))
+ (or members grok
+ (error "bad grouping, must have `members' or `grok'"))
+ (add-hook! hook
+ (if grok
+ (add-props (make-grok-proc name (cadr grok))
+ 'description
+ (assq-ref gdef 'description))
+ (make-members-proc name members))
+ #t))) ; append
+ (read (open-file file OPEN_READ))))
+ files)
+ hook))
+
+(define (scan-api . args)
+ (let ((guile (list-ref args 0))
+ (sofile (list-ref args 1))
+ (grouper (false-if-exception (make-grouper (cddr args))))
+ (ht (make-hash-table 3331)))
+ (scan-Scheme! ht guile)
+ (scan-C! ht sofile)
+ (let ((all (sort (hash-fold (lambda (key value prior-result)
+ (add-props
+ key
+ 'string (symbol->string key)
+ 'scan-data (or (get key 'Scheme)
+ (get key 'C))
+ 'groups (if (get key 'Scheme)
+ '(Scheme)
+ '(C)))
+ (and grouper (run-hook grouper key))
+ (cons key prior-result))
+ '()
+ ht)
+ (lambda (a b)
+ (string<? (get a 'string)
+ (get b 'string))))))
+ (format #t ";;; generated by scan-api -- do not edit!\n\n")
+ (format #t "(\n")
+ (format #t "(meta\n")
+ (format #t " (GUILE_LOAD_PATH . ~S)\n"
+ (or (getenv "GUILE_LOAD_PATH") ""))
+ (format #t " (LTDL_LIBRARY_PATH . ~S)\n"
+ (or (getenv "LTDL_LIBRARY_PATH") ""))
+ (format #t " (guile . ~S)\n" guile)
+ (format #t " (libguileinterface . ~S)\n"
+ (let ((i #f))
+ (scan "(.+)"
+ (format #f "~A -c '(display ~A)'"
+ guile
+ '(assq-ref %guile-build-info
+ 'libguileinterface))
+ (lambda (m) (set! i (match:substring m 1))))
+ i))
+ (format #t " (sofile . ~S)\n" sofile)
+ (format #t " ~A\n"
+ (cons 'groups (append (if grouper
+ (map (lambda (p) (get p 'name))
+ (hook->list grouper))
+ '())
+ '(Scheme C))))
+ (format #t ") ;; end of meta\n")
+ (format #t "(interface\n")
+ (for-each (lambda (x)
+ (format #t "(~A ~A (scan-data ~S))\n"
+ x
+ (cons 'groups (get x 'groups))
+ (get x 'scan-data)))
+ all)
+ (format #t ") ;; end of interface\n")
+ (format #t ") ;; eof\n")))
+ #t)
+
+(define main scan-api)
+
+;;; scan-api ends here
diff --git a/module/scripts/snarf-check-and-output-texi.scm b/module/scripts/snarf-check-and-output-texi.scm
new file mode 100644
index 000000000..82d71f4a9
--- /dev/null
+++ b/module/scripts/snarf-check-and-output-texi.scm
@@ -0,0 +1,311 @@
+;;; snarf-check-and-output-texi --- called by the doc snarfer.
+
+;; Copyright (C) 2001, 2002, 2006, 2011, 2014 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Michael Livshin
+
+;;; Code:
+
+(define-module (scripts snarf-check-and-output-texi)
+ :use-module (ice-9 streams)
+ :use-module (ice-9 match)
+ :export (snarf-check-and-output-texi))
+
+(define %include-in-guild-list #f)
+(define %summary "Transform snarfed .doc files into texinfo documentation.")
+
+;;; why aren't these in some module?
+
+(define-macro (when cond . body)
+ `(if ,cond (begin ,@body)))
+
+(define-macro (unless cond . body)
+ `(if (not ,cond) (begin ,@body)))
+
+(define *manual-flag* #f)
+
+(define (snarf-check-and-output-texi . flags)
+ (if (member "--manual" flags)
+ (set! *manual-flag* #t))
+ (process-stream (current-input-port)))
+
+(define (process-stream port)
+ (let loop ((input (stream-map (match-lambda
+ (('id . s)
+ (cons 'id (string->symbol s)))
+ (('int_dec . s)
+ (cons 'int (string->number s)))
+ (('int_oct . s)
+ (cons 'int (string->number s 8)))
+ (('int_hex . s)
+ (cons 'int (string->number s 16)))
+ ((and x (? symbol?))
+ (cons x x))
+ ((and x (? string?))
+ (cons 'string x))
+ (x x))
+ (make-stream (lambda (s)
+ (let loop ((s s))
+ (cond
+ ((stream-null? s) #t)
+ ((memq (stream-car s) '(eol hash))
+ (loop (stream-cdr s)))
+ (else (cons (stream-car s) (stream-cdr s))))))
+ (port->stream port read)))))
+
+ (unless (stream-null? input)
+ (let ((token (stream-car input)))
+ (if (eq? (car token) 'snarf_cookie)
+ (dispatch-top-cookie (stream-cdr input)
+ loop)
+ (loop (stream-cdr input)))))))
+
+(define (dispatch-top-cookie input cont)
+
+ (when (stream-null? input)
+ (error 'syntax "premature end of file"))
+
+ (let ((token (stream-car input)))
+ (cond
+ ((eq? (car token) 'brace_open)
+ (consume-multiline (stream-cdr input)
+ cont))
+ (else
+ (consume-upto-cookie process-singleline
+ input
+ cont)))))
+
+(define (consume-upto-cookie process input cont)
+ (let loop ((acc '()) (input input))
+
+ (when (stream-null? input)
+ (error 'syntax "premature end of file in directive context"))
+
+ (let ((token (stream-car input)))
+ (cond
+ ((eq? (car token) 'snarf_cookie)
+ (process (reverse! acc))
+ (cont (stream-cdr input)))
+
+ (else (loop (cons token acc) (stream-cdr input)))))))
+
+(define (consume-multiline input cont)
+ (begin-multiline)
+
+ (let loop ((input input))
+
+ (when (stream-null? input)
+ (error 'syntax "premature end of file in multiline context"))
+
+ (let ((token (stream-car input)))
+ (cond
+ ((eq? (car token) 'brace_close)
+ (end-multiline)
+ (cont (stream-cdr input)))
+
+ (else (consume-upto-cookie process-multiline-directive
+ input
+ loop))))))
+
+(define *file* #f)
+(define *line* #f)
+(define *c-function-name* #f)
+(define *function-name* #f)
+(define *snarf-type* #f)
+(define *args* #f)
+(define *sig* #f)
+(define *docstring* #f)
+
+(define (begin-multiline)
+ (set! *file* #f)
+ (set! *line* #f)
+ (set! *c-function-name* #f)
+ (set! *function-name* #f)
+ (set! *snarf-type* #f)
+ (set! *args* #f)
+ (set! *sig* #f)
+ (set! *docstring* #f))
+
+(define *primitive-deffnx-signature* "@deffnx {Scheme Procedure} ")
+(define *primitive-deffnx-sig-length* (string-length *primitive-deffnx-signature*))
+
+(define (end-multiline)
+ (let* ((req (car *sig*))
+ (opt (cadr *sig*))
+ (var (caddr *sig*))
+ (all (+ req opt var)))
+ (if (and (not (eqv? *snarf-type* 'register))
+ (not (= (length *args*) all)))
+ (error (format #f "~A:~A: ~A's C implementation takes ~A args (should take ~A)"
+ *file* *line* *function-name* (length *args*) all)))
+ (let ((nice-sig
+ (if (eq? *snarf-type* 'register)
+ *function-name*
+ (with-output-to-string
+ (lambda ()
+ (format #t "~A" *function-name*)
+ (let loop-req ((args *args*) (r 0))
+ (if (< r req)
+ (begin
+ (format #t " ~A" (car args))
+ (loop-req (cdr args) (+ 1 r)))
+ (let loop-opt ((o 0) (args args) (tail '()))
+ (if (< o opt)
+ (begin
+ (format #t " [~A" (car args))
+ (loop-opt (+ 1 o) (cdr args) (cons #\] tail)))
+ (begin
+ (if (> var 0)
+ (format #t " . ~A"
+ (car args)))
+ (let loop-tail ((tail tail))
+ (if (not (null? tail))
+ (begin
+ (format #t "~A" (car tail))
+ (loop-tail (cdr tail))))))))))))))
+ (scm-deffnx
+ (if (and *manual-flag* (eq? *snarf-type* 'primitive))
+ (with-output-to-string
+ (lambda ()
+ (format #t "@deffnx {C Function} ~A (" *c-function-name*)
+ (unless (null? *args*)
+ (format #t "~A" (car *args*))
+ (let loop ((args (cdr *args*)))
+ (unless (null? args)
+ (format #t ", ~A" (car args))
+ (loop (cdr args)))))
+ (format #t ")\n")))
+ #f)))
+ (format #t "\n ~A\n" *function-name*)
+ (format #t "@c snarfed from ~A:~A\n" *file* *line*)
+ (format #t "@deffn {Scheme Procedure} ~A\n" nice-sig)
+ (let loop ((strings *docstring*) (scm-deffnx scm-deffnx))
+ (cond ((null? strings))
+ ((or (not scm-deffnx)
+ (and (>= (string-length (car strings))
+ *primitive-deffnx-sig-length*)
+ (string=? (substring (car strings)
+ 0 *primitive-deffnx-sig-length*)
+ *primitive-deffnx-signature*)))
+ (display (car strings))
+ (loop (cdr strings) scm-deffnx))
+ (else (display scm-deffnx)
+ (loop strings #f))))
+ (display "\n")
+ (display "@end deffn\n"))))
+
+(define (texi-quote s)
+ (let rec ((i 0))
+ (if (= i (string-length s))
+ ""
+ (string-append (let ((ss (substring s i (+ i 1))))
+ (if (string=? ss "@")
+ "@@"
+ ss))
+ (rec (+ i 1))))))
+
+(define (process-multiline-directive l)
+
+ (define do-args
+ (match-lambda
+
+ (('(paren_close . paren_close))
+ '())
+
+ (('(comma . comma) rest ...)
+ (do-args rest))
+
+ (('(id . SCM) ('id . name) rest ...)
+ (cons name (do-args rest)))
+
+ (x (error (format #f "invalid argument syntax: ~A" (map cdr x))))))
+
+ (define do-arglist
+ (match-lambda
+
+ (('(paren_open . paren_open) '(id . void) '(paren_close . paren_close))
+ '())
+
+ (('(paren_open . paren_open) rest ...)
+ (do-args rest))
+
+ (x (error (format #f "invalid arglist syntax: ~A" (map cdr x))))))
+
+ (define do-command
+ (match-lambda
+
+ (('cname ('id . name))
+ (set! *c-function-name* (texi-quote (symbol->string name))))
+
+ (('fname ('string . name) ...)
+ (set! *function-name* (texi-quote (apply string-append name))))
+
+ (('type ('id . type))
+ (set! *snarf-type* type))
+
+ (('type ('int . num))
+ (set! *snarf-type* num))
+
+ (('location ('string . file) ('int . line))
+ (set! *file* file)
+ (set! *line* line))
+
+ (('arglist rest ...)
+ (set! *args* (do-arglist rest)))
+
+ (('argsig ('int . req) ('int . opt) ('int . var))
+ (set! *sig* (list req opt var)))
+
+ (x (error (format #f "unknown doc attribute: ~A" x)))))
+
+ (define do-directive
+ (match-lambda
+
+ ((('id . command) rest ...)
+ (do-command (cons command rest)))
+
+ ((('string . string) ...)
+ (set! *docstring* string))
+
+ (x (error (format #f "unknown doc attribute syntax: ~A" x)))))
+
+ (do-directive l))
+
+(define (process-singleline l)
+
+ (define do-argpos
+ (match-lambda
+ ((('id . name) ('int . pos) ('int . line))
+ (let ((idx (list-index *args* name)))
+ (when idx
+ (unless (= (+ idx 1) pos)
+ (display (format #f "~A:~A: wrong position for argument ~A: ~A (should be ~A)\n"
+ *file* line name pos (+ idx 1))
+ (current-error-port))))))
+ (x #f)))
+
+ (define do-command
+ (match-lambda
+ (('(id . argpos) rest ...)
+ (do-argpos rest))
+ (x (error (format #f "unknown check: ~A" x)))))
+
+ (when *function-name*
+ (do-command l)))
+
+(define main snarf-check-and-output-texi)
diff --git a/module/scripts/snarf-guile-m4-docs.scm b/module/scripts/snarf-guile-m4-docs.scm
new file mode 100644
index 000000000..4e59f536d
--- /dev/null
+++ b/module/scripts/snarf-guile-m4-docs.scm
@@ -0,0 +1,86 @@
+;;; snarf-guile-m4-docs --- Parse guile.m4 comments for texi documentation
+
+;; Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: snarf-guile-m4-docs FILE
+;;
+;; Grep FILE for comments preceding macro definitions, massage
+;; them into valid texi, and display to stdout. For each comment,
+;; lines preceding "^# Usage:" are discarded.
+;;
+;; TODO: Generalize.
+
+;;; Code:
+
+(define-module (scripts snarf-guile-m4-docs)
+ :use-module (ice-9 rdelim)
+ :export (snarf-guile-m4-docs))
+
+(define %include-in-guild-list #f)
+(define %summary "Snarf out texinfo documentation from .m4 files.")
+
+(define (display-texi lines)
+ (display "@deffn {Autoconf Macro}")
+ (for-each (lambda (line)
+ (display (cond ((and (>= (string-length line) 2)
+ (string=? "# " (substring line 0 2)))
+ (substring line 2))
+ ((string=? "#" (substring line 0 1))
+ (substring line 1))
+ (else line)))
+ (newline))
+ lines)
+ (display "@end deffn")
+ (newline) (newline))
+
+(define (prefix? line sub)
+ (false-if-exception
+ (string=? sub (substring line 0 (string-length sub)))))
+
+(define (massage-usage line)
+ (let loop ((line (string->list line)) (acc '()))
+ (if (null? line)
+ (list (list->string (reverse acc)))
+ (loop (cdr line)
+ (cons (case (car line)
+ ((#\( #\) #\,) #\space)
+ (else (car line)))
+ acc)))))
+
+(define (snarf-guile-m4-docs . args)
+ (let* ((p (open-file (car args) "r"))
+ (next (lambda () (read-line p))))
+ (let loop ((line (next)) (acc #f))
+ (or (eof-object? line)
+ (cond ((prefix? line "# Usage:")
+ (loop (next) (massage-usage (substring line 8))))
+ ((prefix? line "AC_DEFUN")
+ (display-texi (reverse acc))
+ (loop (next) #f))
+ ((and acc (prefix? line "#"))
+ (loop (next) (cons line acc)))
+ (else
+ (loop (next) #f)))))))
+
+(define main snarf-guile-m4-docs)
+
+;;; snarf-guile-m4-docs ends here
diff --git a/module/scripts/summarize-guile-TODO.scm b/module/scripts/summarize-guile-TODO.scm
new file mode 100644
index 000000000..8b119e0ec
--- /dev/null
+++ b/module/scripts/summarize-guile-TODO.scm
@@ -0,0 +1,213 @@
+;;; summarize-guile-TODO --- Display Guile TODO list in various ways
+
+;; Copyright (C) 2002, 2006, 2010, 2011 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; Usage: summarize-guile-TODO TODOFILE
+;;
+;; The TODOFILE is typically Guile's (see workbook/tasks/README)
+;; presumed to serve as our signal to ourselves (lest we want real
+;; bosses hassling us) wrt to the overt message "items to do" as well as
+;; the messages that can be inferred from its structure.
+;;
+;; This program reads TODOFILE and displays interpretations on its
+;; structure, including registered markers and ownership, in various
+;; ways.
+;;
+;; A primary interest in any task is its parent task. The output
+;; summarization by default lists every item and its parent chain.
+;; Top-level parents are not items. You can use these command-line
+;; options to modify the selection and display (selection criteria
+;; are ANDed together):
+;;
+;; -i, --involved USER -- select USER-involved items
+;; -p, --personal USER -- select USER-responsible items
+;; -t, --todo -- select unfinished items (status "-")
+;; -d, --done -- select finished items (status "+")
+;; -r, --review -- select review items (marker "R")
+;;
+;; -w, --who -- also show who is associated w/ the item
+;; -n, --no-parent -- do not show parent chain
+;;
+;;
+;; Usage from a Scheme program:
+;; (summarize-guile-TODO . args) ; uses first arg only
+;;
+;;
+;; Bugs: (1) Markers are scanned in sequence: D R X N%. This means "XD"
+;; and the like are completely dropped. However, such strings
+;; are unlikely to be used if the markers are chosen to be
+;; somewhat exclusive, which is currently the case for D R X.
+;; N% used w/ these needs to be something like: "D25%" (this
+;; means discussion accounts for 1/4 of the task).
+;;
+;; TODO: Implement more various ways. (Patches welcome.)
+;; Add support for ORing criteria.
+
+;;; Code:
+(debug-enable 'backtrace)
+
+(define-module (scripts summarize-guile-TODO)
+ :use-module (scripts read-text-outline)
+ :use-module (ice-9 getopt-long)
+ :autoload (srfi srfi-13) (string-tokenize) ; string library
+ :autoload (srfi srfi-14) (char-set) ; string library
+ :autoload (ice-9 common-list) (remove-if-not)
+ :export (summarize-guile-TODO))
+
+(define %include-in-guild-list #f)
+(define %summary "A quaint relic of the past.")
+
+(define put set-object-property!)
+(define get object-property)
+
+(define (as-leaf x)
+ (cond ((get x 'who)
+ => (lambda (who)
+ (put x 'who
+ (map string->symbol
+ (string-tokenize who (char-set #\:)))))))
+ (cond ((get x 'pct-done)
+ => (lambda (pct-done)
+ (put x 'pct-done (string->number pct-done)))))
+ x)
+
+(define (hang-by-the-leaves trees)
+ (let ((leaves '()))
+ (letrec ((hang (lambda (tree parent)
+ (if (list? tree)
+ (begin
+ (put (car tree) 'parent parent)
+ (for-each (lambda (child)
+ (hang child (car tree)))
+ (cdr tree)))
+ (begin
+ (put tree 'parent parent)
+ (set! leaves (cons (as-leaf tree) leaves)))))))
+ (for-each (lambda (tree)
+ (hang tree #f))
+ trees))
+ leaves))
+
+(define (read-TODO file)
+ (hang-by-the-leaves
+ ((make-text-outline-reader
+ "(([ ][ ])*)([-+])(D*)(R*)(X*)(([0-9]+)%)* *([^[]*)(\\[(.*)\\])*"
+ '((level-substring-divisor . 2)
+ (body-submatch-number . 9)
+ (extra-fields . ((status . 3)
+ (design? . 4)
+ (review? . 5)
+ (extblock? . 6)
+ (pct-done . 8)
+ (who . 11)))))
+ (open-file file "r"))))
+
+(define (select-items p items)
+ (let ((sub '()))
+ (cond ((option-ref p 'involved #f)
+ => (lambda (u)
+ (let ((u (string->symbol u)))
+ (set! sub (cons
+ (lambda (x)
+ (and (get x 'who)
+ (memq u (get x 'who))))
+ sub))))))
+ (cond ((option-ref p 'personal #f)
+ => (lambda (u)
+ (let ((u (string->symbol u)))
+ (set! sub (cons
+ (lambda (x)
+ (cond ((get x 'who)
+ => (lambda (ls)
+ (eq? (car (reverse ls))
+ u)))
+ (else #f)))
+ sub))))))
+ (for-each (lambda (pair)
+ (cond ((option-ref p (car pair) #f)
+ (set! sub (cons (cdr pair) sub)))))
+ `((todo . ,(lambda (x) (string=? (get x 'status) "-")))
+ (done . ,(lambda (x) (string=? (get x 'status) "+")))
+ (review . ,(lambda (x) (get x 'review?)))))
+ (let loop ((sub (reverse sub)) (items items))
+ (if (null? sub)
+ (reverse items)
+ (loop (cdr sub) (remove-if-not (car sub) items))))))
+
+(define (make-display-item show-who? show-parent?)
+ (let ((show-who
+ (if show-who?
+ (lambda (item)
+ (cond ((get item 'who)
+ => (lambda (who) (format #f " ~A" who)))
+ (else "")))
+ (lambda (item) "")))
+ (show-parents
+ (if show-parent?
+ (lambda (item)
+ (let loop ((parent (get item 'parent)) (indent 2))
+ (and parent
+ (begin
+ (format #t "under : ~A~A\n"
+ (make-string indent #\space)
+ parent)
+ (loop (get parent 'parent) (+ 2 indent))))))
+ (lambda (item) #t))))
+ (lambda (item)
+ (format #t "status: ~A~A~A~A~A~A\nitem : ~A\n"
+ (get item 'status)
+ (if (get item 'design?) "D" "")
+ (if (get item 'review?) "R" "")
+ (if (get item 'extblock?) "X" "")
+ (cond ((get item 'pct-done)
+ => (lambda (pct-done)
+ (format #f " ~A%" pct-done)))
+ (else ""))
+ (show-who item)
+ item)
+ (show-parents item))))
+
+(define (display-items p items)
+ (let ((display-item (make-display-item (option-ref p 'who #f)
+ (not (option-ref p 'no-parent #f))
+ )))
+ (for-each display-item items)))
+
+(define (summarize-guile-TODO . args)
+ (let ((p (getopt-long (cons "summarize-guile-TODO" args)
+ '((who (single-char #\w))
+ (no-parent (single-char #\n))
+ (involved (single-char #\i)
+ (value #t))
+ (personal (single-char #\p)
+ (value #t))
+ (todo (single-char #\t))
+ (done (single-char #\d))
+ (review (single-char #\r))
+ ;; Add options here.
+ ))))
+ (display-items p (select-items p (read-TODO (car (option-ref p '() #f))))))
+ #t) ; exit val
+
+(define main summarize-guile-TODO)
+
+;;; summarize-guile-TODO ends here
diff --git a/module/scripts/use2dot.scm b/module/scripts/use2dot.scm
new file mode 100644
index 000000000..975a9c4a4
--- /dev/null
+++ b/module/scripts/use2dot.scm
@@ -0,0 +1,110 @@
+;;; use2dot --- Display module dependencies as a DOT specification
+
+;; Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public License
+;; as published by the Free Software Foundation; either version 3, 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this software; see the file COPYING.LESSER. If
+;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Thien-Thi Nguyen
+
+;;; 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. [The "N" label is not implemented.]
+;;
+;; 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:
+;; -m, --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-user)'.
+
+;;; Code:
+
+(define-module (scripts use2dot)
+ :autoload (ice-9 getopt-long) (getopt-long)
+ :use-module ((srfi srfi-13) :select (string-join))
+ :use-module ((scripts frisk)
+ :select (make-frisker edge-type edge-up edge-down))
+ :export (use2dot))
+
+(define %summary "Print a module's dependencies in graphviz format.")
+
+(define *default-module* '(guile-user))
+
+(define (q s) ; quote
+ (format #f "~S" s))
+
+(define (vv pairs) ; => ("var=val" ...)
+ (map (lambda (pair)
+ (format #f "~A=~A" (car pair) (cdr pair)))
+ pairs))
+
+(define (>>header)
+ (format #t "digraph use2dot {\n")
+ (for-each (lambda (s) (format #t " ~A;\n" s))
+ (vv `((label . ,(q "Guile Module Dependencies"))
+ ;;(rankdir . LR)
+ ;;(size . ,(q "7.5,10"))
+ (ratio . fill)
+ ;;(nodesep . ,(q "0.05"))
+ ))))
+
+(define (>>body edges)
+ (for-each
+ (lambda (edge)
+ (format #t " \"~A\" -> \"~A\"" (edge-down edge) (edge-up edge))
+ (cond ((case (edge-type edge)
+ ((autoload) '((style . dotted) (fontsize . 5)))
+ ((computed) '((style . bold)))
+ (else #f))
+ => (lambda (etc)
+ (format #t " [~A]" (string-join (vv etc) ",")))))
+ (format #t ";\n"))
+ edges))
+
+(define (>>footer)
+ (format #t "}"))
+
+(define (>> edges)
+ (>>header)
+ (>>body edges)
+ (>>footer))
+
+(define (use2dot . args)
+ (let* ((parsed-args (getopt-long (cons "use2dot" args) ;;; kludge
+ '((default-module
+ (single-char #\m) (value #t)))))
+ (=m (option-ref parsed-args 'default-module *default-module*))
+ (scan (make-frisker `(default-module . ,=m)))
+ (files (option-ref parsed-args '() '())))
+ (>> (reverse ((scan files) 'edges)))))
+
+(define main use2dot)
+
+;;; use2dot ends here