summaryrefslogtreecommitdiff
path: root/scripts
diff options
context:
space:
mode:
Diffstat (limited to 'scripts')
-rw-r--r--scripts/.cvsignore2
-rw-r--r--scripts/ChangeLog286
-rw-r--r--scripts/Makefile.am67
-rwxr-xr-xscripts/PROGRAM45
-rw-r--r--scripts/README76
-rwxr-xr-xscripts/api-diff181
-rwxr-xr-xscripts/autofrisk221
-rwxr-xr-xscripts/display-commentary70
-rwxr-xr-xscripts/doc-snarf442
-rwxr-xr-xscripts/frisk292
-rwxr-xr-xscripts/generate-autoload146
-rwxr-xr-xscripts/lint319
-rwxr-xr-xscripts/punify89
-rwxr-xr-xscripts/read-rfc822133
-rwxr-xr-xscripts/read-scheme-source284
-rwxr-xr-xscripts/read-text-outline255
-rwxr-xr-xscripts/scan-api225
-rwxr-xr-xscripts/snarf-check-and-output-texi313
-rwxr-xr-xscripts/snarf-guile-m4-docs88
-rwxr-xr-xscripts/summarize-guile-TODO214
-rwxr-xr-xscripts/use2dot113
21 files changed, 0 insertions, 3861 deletions
diff --git a/scripts/.cvsignore b/scripts/.cvsignore
deleted file mode 100644
index 282522db0..000000000
--- a/scripts/.cvsignore
+++ /dev/null
@@ -1,2 +0,0 @@
-Makefile
-Makefile.in
diff --git a/scripts/ChangeLog b/scripts/ChangeLog
deleted file mode 100644
index e6b36f8f1..000000000
--- a/scripts/ChangeLog
+++ /dev/null
@@ -1,286 +0,0 @@
-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/scripts/Makefile.am b/scripts/Makefile.am
deleted file mode 100644
index 46d1885d0..000000000
--- a/scripts/Makefile.am
+++ /dev/null
@@ -1,67 +0,0 @@
-## Process this file with automake to produce Makefile.in.
-##
-## Copyright (C) 2002 Free Software Foundation, Inc.
-##
-## This file is part of GUILE.
-##
-## GUILE is free software; you can redistribute it and/or modify
-## it under the terms of the GNU General Public License as
-## published by the Free Software Foundation; either version 2, or
-## (at your option) any later version.
-##
-## GUILE is distributed in the hope that it will be useful, but
-## WITHOUT ANY WARRANTY; without even the implied warranty of
-## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-## GNU General Public License for more details.
-##
-## You should have received a copy of the GNU General Public
-## License along with GUILE; see the file COPYING. If not, write
-## to the Free Software Foundation, Inc., 59 Temple Place, Suite
-## 330, Boston, MA 02111-1307 USA
-
-AUTOMAKE_OPTIONS = gnu
-
-# These should be installed and distributed.
-scripts_sources = \
- PROGRAM \
- autofrisk \
- display-commentary \
- doc-snarf \
- frisk \
- generate-autoload \
- lint \
- punify \
- read-scheme-source \
- read-text-outline \
- use2dot \
- snarf-check-and-output-texi \
- summarize-guile-TODO \
- scan-api \
- api-diff \
- read-rfc822
-
-subpkgdatadir = $(pkgdatadir)/$(VERSION)/scripts
-subpkgdata_SCRIPTS = $(scripts_sources)
-
-EXTRA_DIST = $(scripts_sources)
-
-list:
- @echo $(scripts_sources)
-
-include $(top_srcdir)/am/pre-inst-guile
-
-overview: $(scripts_sources)
- @echo '----------------------------'
- @echo Overview
- @echo I. Commentaries
- @echo II. Module Interfaces
- @echo '----------------------------'
- @echo I. Commentaries
- @echo '----------------------------'
- $(preinstguiletool)/display-commentary $^
- @echo '----------------------------'
- @echo II. Module Interfaces
- @echo '----------------------------'
- $(preinstguiletool)/frisk $^
-
-# Makefile.am ends here
diff --git a/scripts/PROGRAM b/scripts/PROGRAM
deleted file mode 100755
index 9ce5f022a..000000000
--- a/scripts/PROGRAM
+++ /dev/null
@@ -1,45 +0,0 @@
-#!/bin/sh
-# aside from this initial boilerplate, this is actually -*- scheme -*- code
-main='(module-ref (resolve-module '\''(scripts PROGRAM)) '\'main')'
-exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; PROGRAM --- Does something
-
-;; Copyright (C) 2002 Free Software Foundation, Inc.
-;;
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2, or
-;; (at your option) any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this software; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;; Boston, MA 02111-1307 USA
-
-;;; Author: J.R.Hacker
-
-;;; Commentary:
-
-;; Usage: PROGRAM [ARGS]
-;;
-;; PROGRAM does something.
-;;
-;; TODO: Write it!
-
-;;; Code:
-
-(define-module (scripts PROGRAM)
- :export (PROGRAM))
-
-(define (PROGRAM . args)
- #t)
-
-(define main PROGRAM)
-
-;;; PROGRAM ends here
diff --git a/scripts/README b/scripts/README
deleted file mode 100644
index 56dd286fb..000000000
--- a/scripts/README
+++ /dev/null
@@ -1,76 +0,0 @@
-Overview and Usage
-------------------
-
-This directory contains Scheme programs, some useful in maintaining Guile.
-On "make install", these programs are copied to PKGDATADIR/VERSION/scripts.
-
-You can invoke a program from the shell, or alternatively, load its file
-as a Guile Scheme module, and use its exported procedure(s) from Scheme code.
-Typically for any PROGRAM:
-
- (use-modules (scripts PROGRAM))
- (PROGRAM ARG1 ARG2 ...)
-
-For programs that write to stdout, you might try, instead:
-
- (use-modules (scripts PROGRAM))
- (with-output-to-string (lambda () (PROGRAM ARG1 ARG2 ...)))
-
-Note that all args must be strings.
-
-To see PROGRAM's commentary, which may or may not be helpful:
-
- (help (scripts PROGRAM))
-
-To see all commentaries and module dependencies, try: "make overview".
-
-If you want to try the programs before installing Guile, you will probably
-need to set environment variable GUILE_LOAD_PATH to be the parent directory.
-This can be done in Bourne-compatible shells like so:
-
- GUILE_LOAD_PATH=`(cd .. ; pwd)`
- export GUILE_LOAD_PATH
-
-[FIXME: Can someone supply the csh-compatible equivalent?]
-
-
-
-How to Contribute
------------------
-
-See template file PROGRAM for a quick start.
-
-Programs must follow the "executable module" convention, documented here:
-
-- The file name must not end in ".scm".
-
-- The file must be executable (chmod +x).
-
-- The module name must be "(scripts PROGRAM)". A procedure named PROGRAM w/
- signature "(PROGRAM . args)" must be exported. Basically, use some variant
- of the form:
-
- (define-module (scripts PROGRAM)
- :export (PROGRAM))
-
- Feel free to export other definitions useful in the module context.
-
-- There must be the alias:
-
- (define main PROGRAM)
-
- However, `main' must NOT be exported.
-
-- The beginning of the file must use the following invocation sequence:
-
- #!/bin/sh
- main='(module-ref (resolve-module '\''(scripts PROGRAM)) '\'main')'
- exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
- !#
-
-Following these conventions allows the program file to be used as module
-(scripts PROGRAM) in addition to as a standalone executable. Please also
-include a helpful Commentary section w/ some usage info.
-
-
-[README ends here]
diff --git a/scripts/api-diff b/scripts/api-diff
deleted file mode 100755
index 433ff0f45..000000000
--- a/scripts/api-diff
+++ /dev/null
@@ -1,181 +0,0 @@
-#!/bin/sh
-# aside from this initial boilerplate, this is actually -*- scheme -*- code
-main='(module-ref (resolve-module '\''(scripts api-diff)) '\'main')'
-exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; api-diff --- diff guile-api.alist files
-
-;; Copyright (C) 2002 Free Software Foundation, Inc.
-;;
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2, or
-;; (at your option) any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this software; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;; Boston, MA 02111-1307 USA
-
-;;; 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 (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/scripts/autofrisk b/scripts/autofrisk
deleted file mode 100755
index cbb91d271..000000000
--- a/scripts/autofrisk
+++ /dev/null
@@ -1,221 +0,0 @@
-#!/bin/sh
-# aside from this initial boilerplate, this is actually -*- scheme -*- code
-main='(module-ref (resolve-module '\''(scripts autofrisk)) '\'main')'
-exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; autofrisk --- Generate module checks for use with auto* tools
-
-;; Copyright (C) 2002 Free Software Foundation, Inc.
-;;
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2, or
-;; (at your option) any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this software; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;; Boston, MA 02111-1307 USA
-
-;;; 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 *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))
- (prog (cfg 'non-critical))
- (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/scripts/display-commentary b/scripts/display-commentary
deleted file mode 100755
index 59b0890fc..000000000
--- a/scripts/display-commentary
+++ /dev/null
@@ -1,70 +0,0 @@
-#!/bin/sh
-# aside from this initial boilerplate, this is actually -*- scheme -*- code
-main='(module-ref (resolve-module '\''(scripts display-commentary)) '\'main')'
-exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; display-commentary --- As advertized
-
-;; Copyright (C) 2001 Free Software Foundation, Inc.
-;;
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2, or
-;; (at your option) any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this software; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;; Boston, MA 02111-1307 USA
-
-;;; 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 (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/scripts/doc-snarf b/scripts/doc-snarf
deleted file mode 100755
index 5b72fc5f8..000000000
--- a/scripts/doc-snarf
+++ /dev/null
@@ -1,442 +0,0 @@
-#!/bin/sh
-# aside from this initial boilerplate, this is actually -*- scheme -*- code
-main='(module-ref (resolve-module '\''(scripts doc-snarf)) '\'main')'
-exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; doc-snarf --- Extract documentation from source files
-
-;; Copyright (C) 2001 Free Software Foundation, Inc.
-;;
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2, or
-;; (at your option) any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this software; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;; Boston, MA 02111-1307 USA
-
-;;; 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.
-;; ../libguile/guile-doc-snarf emulation
-
-(define doc-snarf-version "0.0.2") ; please update before publishing!
-
-;;; Code:
-
-(define-module (scripts doc-snarf)
- :use-module (ice-9 getopt-long)
- :use-module (ice-9 regex)
- :use-module (ice-9 string-fun)
- :use-module (ice-9 rdelim)
- :export (doc-snarf))
-
-(define command-synopsis
- '((version (single-char #\v) (value #f))
- (help (single-char #\h) (value #f))
- (output (single-char #\o) (value #t))
- (texinfo (single-char #\t) (value #f))
- (lang (single-char #\l) (value #t))))
-
-;; Display version information and exit.
-;;-ttn-mod: use var
-(define (display-version)
- (display "doc-snarf ") (display doc-snarf-version) (newline))
-
-;; Display the usage help message and exit.
-;;-ttn-mod: change option "source" to "lang"
-(define (display-help)
- (display "Usage: doc-snarf [options...] inputfile\n")
- (display " --help, -h Show this usage information\n")
- (display " --version, -v Show version information\n")
- (display
- " --output=FILE, -o Specify output file [default=stdout]\n")
- (display " --texinfo, -t Format output as texinfo\n")
- (display " --lang=[c,scheme], -l Specify the input language\n"))
-
-;; Main program.
-;;-ttn-mod: canonicalize lang
-(define (doc-snarf . args)
- (let ((options (getopt-long (cons "doc-snarf" args) command-synopsis)))
- (let ((help-wanted (option-ref options 'help #f))
- (version-wanted (option-ref options 'version #f))
- (texinfo-wanted (option-ref options 'texinfo #f))
- (lang (string->symbol
- (string-downcase (option-ref options 'lang "scheme")))))
- (cond
- (version-wanted (display-version))
- (help-wanted (display-help))
- (else
- (let ((input (option-ref options '() #f))
- (output (option-ref options 'output #f)))
- (if
- ;; Bonard B. Timmons III says `(pair? input)' alone is sufficient.
- ;; (and input (pair? input))
- (pair? input)
- (snarf-file (car input) output texinfo-wanted lang)
- (display-help))))))))
-
-(define main doc-snarf)
-
-;; Supported languages and their parameters. Each element has form:
-;; (LANG DOC-START DOC-END DOC-PREFIX OPT-PREFIX SIG-START STD-INT-DOC?)
-;; LANG is a symbol, STD-INT-DOC? is a boolean indicating whether or not
-;; LANG supports "standard internal docstring" (a string after the formals),
-;; everything else is a string specifying a regexp.
-;;-ttn-mod: new var
-(define supported-languages
- '((c
- "^/\\*(.*)"
- "^ \\*/"
- "^ \\* (.*)"
- "^ \\*-(.*)"
- "NOTHING AT THIS TIME!!!"
- #f
- )
- (scheme
- "^;; (.*)"
- "^;;\\."
- "^;; (.*)"
- "^;;-(.*)"
- "^\\(define"
- #t
- )))
-
-;; Get @var{lang}'s @var{parameter}. Both args are symbols.
-;;-ttn-mod: new proc
-(define (lang-parm lang parm)
- (list-ref (assq-ref supported-languages lang)
- (case parm
- ((docstring-start) 0)
- ((docstring-end) 1)
- ((docstring-prefix) 2)
- ((option-prefix) 3)
- ((signature-start) 4)
- ((std-int-doc?) 5))))
-
-;; Snarf all docstrings from the file @var{input} and write them to
-;; file @var{output}. Use texinfo format for the output if
-;; @var{texinfo?} is true.
-;;-ttn-mod: don't use string comparison, consult table instead
-(define (snarf-file input output texinfo? lang)
- (or (memq lang (map car supported-languages))
- (error "doc-snarf: input language must be c or scheme."))
- (write-output (snarf input lang) output
- (if texinfo? format-texinfo format-plain)))
-
-;; fixme: this comment is required to trigger standard internal
-;; docstring snarfing... ideally, it wouldn't be necessary.
-;;-ttn-mod: new proc, from snarf-docs (aren't these names fun?)
-(define (find-std-int-doc line input-port)
- "Unread @var{line} from @var{input-port}, then read in the entire form and
-return the standard internal docstring if found. Return #f if not."
- (unread-string line input-port) ; ugh
- (let ((form (read input-port)))
- (cond ((and (list? form) ; (define (PROC ARGS) "DOC" ...)
- (< 3 (length form))
- (eq? 'define (car form))
- (pair? (cadr form))
- (symbol? (caadr form))
- (string? (caddr form)))
- (caddr form))
- ((and (list? form) ; (define VAR (lambda ARGS "DOC" ...))
- (< 2 (length form))
- (eq? 'define (car form))
- (symbol? (cadr form))
- (list? (caddr form))
- (< 3 (length (caddr form)))
- (eq? 'lambda (car (caddr form)))
- (string? (caddr (caddr form))))
- (caddr (caddr form)))
- (else #f))))
-
-;; Split @var{string} into lines, adding @var{prefix} to each.
-;;-ttn-mod: new proc
-(define (split-prefixed string prefix)
- (separate-fields-discarding-char
- #\newline string
- (lambda lines
- (map (lambda (line)
- (string-append prefix line))
- lines))))
-
-;; snarf input-file output-file
-;; Extract docstrings from the input file @var{input}, presumed
-;; to be written in language @var{lang}.
-;;-Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
-;;-Created: 2001-02-17
-;;-ttn-mod: regluarize lang parm lookup, add "std int doc" snarfing (2 places)
-(define (snarf input-file lang)
- (let* ((i-p (open-input-file input-file))
- (parm-regexp (lambda (parm) (make-regexp (lang-parm lang parm))))
- (docstring-start (parm-regexp 'docstring-start))
- (docstring-end (parm-regexp 'docstring-end))
- (docstring-prefix (parm-regexp 'docstring-prefix))
- (option-prefix (parm-regexp 'option-prefix))
- (signature-start (parm-regexp 'signature-start))
- (augmented-options
- (lambda (line i-p options)
- (let ((int-doc (and (lang-parm lang 'std-int-doc?)
- (let ((d (find-std-int-doc line i-p)))
- (and d (split-prefixed d "internal: "))))))
- (if int-doc
- (append (reverse int-doc) options)
- options)))))
-
- (let lp ((line (read-line i-p)) (state 'neutral) (doc-strings '())
- (options '()) (entries '()) (lno 0))
- (cond
- ((eof-object? line)
- (close-input-port i-p)
- (reverse entries))
-
- ;; State 'neutral: we're currently not within a docstring or
- ;; option section
- ((eq? state 'neutral)
- (let ((m (regexp-exec docstring-start line)))
- (if m
- (lp (read-line i-p) 'doc-string
- (list (match:substring m 1)) '() entries (+ lno 1))
- (lp (read-line i-p) state '() '() entries (+ lno 1)))))
-
- ;; State 'doc-string: we have started reading a docstring and
- ;; are waiting for more, for options or for a define.
- ((eq? state 'doc-string)
- (let ((m0 (regexp-exec docstring-prefix line))
- (m1 (regexp-exec option-prefix line))
- (m2 (regexp-exec signature-start line))
- (m3 (regexp-exec docstring-end line)))
- (cond
- (m0
- (lp (read-line i-p) 'doc-string
- (cons (match:substring m0 1) doc-strings) '() entries
- (+ lno 1)))
- (m1
- (lp (read-line i-p) 'options
- doc-strings (cons (match:substring m1 1) options) entries
- (+ lno 1)))
- (m2
- (let ((options (augmented-options line i-p options))) ; ttn-mod
- (lp (read-line i-p) 'neutral '() '()
- (cons (parse-entry doc-strings options line input-file lno)
- entries)
- (+ lno 1))))
- (m3
- (lp (read-line i-p) 'neutral '() '()
- (cons (parse-entry doc-strings options #f input-file lno)
- entries)
- (+ lno 1)))
- (else
- (lp (read-line i-p) 'neutral '() '() entries (+ lno 1))))))
-
- ;; State 'options: We're waiting for more options or for a
- ;; define.
- ((eq? state 'options)
- (let ((m1 (regexp-exec option-prefix line))
- (m2 (regexp-exec signature-start line))
- (m3 (regexp-exec docstring-end line)))
- (cond
- (m1
- (lp (read-line i-p) 'options
- doc-strings (cons (match:substring m1 1) options) entries
- (+ lno 1)))
- (m2
- (let ((options (augmented-options line i-p options))) ; ttn-mod
- (lp (read-line i-p) 'neutral '() '()
- (cons (parse-entry doc-strings options line input-file lno)
- entries)
- (+ lno 1))))
- (m3
- (lp (read-line i-p) 'neutral '() '()
- (cons (parse-entry doc-strings options #f input-file lno)
- entries)
- (+ lno 1)))
- (else
- (lp (read-line i-p) 'neutral '() '() entries (+ lno 1))))))))))
-
-(define (make-entry symbol signature docstrings options filename line)
- (vector 'entry symbol signature docstrings options filename line))
-(define (entry-symbol e)
- (vector-ref e 1))
-(define (entry-signature e)
- (vector-ref e 2))
-(define (entry-docstrings e)
- (vector-ref e 3))
-(define (entry-options e)
- (vector-ref e 4))
-(define (entry-filename e)
- (vector-ref e 5))
-(define (entry-line e)
- "This docstring will not be snarfed, unfortunately..."
- (vector-ref e 6))
-
-;; Create a docstring entry from the docstring line list
-;; @var{doc-strings}, the option line list @var{options} and the
-;; define line @var{def-line}
-(define (parse-entry docstrings options def-line filename line-no)
-; (write-line docstrings)
- (cond
- (def-line
- (make-entry (get-symbol def-line)
- (make-prototype def-line) (reverse docstrings)
- (reverse options) filename
- (+ (- line-no (length docstrings) (length options)) 1)))
- ((> (length docstrings) 0)
- (make-entry (string->symbol (car (reverse docstrings)))
- (car (reverse docstrings))
- (cdr (reverse docstrings))
- (reverse options) filename
- (+ (- line-no (length docstrings) (length options)) 1)))
- (else
- (make-entry 'foo "" (reverse docstrings) (reverse options) filename
- (+ (- line-no (length docstrings) (length options)) 1)))))
-
-;; Create a string which is a procedure prototype. The necessary
-;; information for constructing the prototype is taken from the line
-;; @var{def-line}, which is a line starting with @code{(define...}.
-(define (make-prototype def-line)
- (call-with-input-string
- def-line
- (lambda (s-p)
- (let* ((paren (read-char s-p))
- (keyword (read s-p))
- (tmp (read s-p)))
- (cond
- ((pair? tmp)
- (join-symbols tmp))
- ((symbol? tmp)
- (symbol->string tmp))
- (else
- ""))))))
-
-(define (get-symbol def-line)
- (call-with-input-string
- def-line
- (lambda (s-p)
- (let* ((paren (read-char s-p))
- (keyword (read s-p))
- (tmp (read s-p)))
- (cond
- ((pair? tmp)
- (car tmp))
- ((symbol? tmp)
- tmp)
- (else
- 'foo))))))
-
-;; Append the symbols in the string list @var{s}, separated with a
-;; space character.
-(define (join-symbols s)
- (cond ((null? s)
- "")
- ((symbol? s)
- (string-append ". " (symbol->string s)))
- ((null? (cdr s))
- (symbol->string (car s)))
- (else
- (string-append (symbol->string (car s)) " " (join-symbols (cdr s))))))
-
-;; Write @var{entries} to @var{output-file} using @var{writer}.
-;; @var{writer} is a proc that takes one entry.
-;; If @var{output-file} is #f, write to stdout.
-;;-ttn-mod: new proc
-(define (write-output entries output-file writer)
- (with-output-to-port (cond (output-file (open-output-file output-file))
- (else (current-output-port)))
- (lambda () (for-each writer entries))))
-
-;; Write an @var{entry} using texinfo format.
-;;-ttn-mod: renamed from `texinfo-output', distilled
-(define (format-texinfo entry)
- (display "\n\f")
- (display (entry-symbol entry))
- (newline)
- (display "@c snarfed from ")
- (display (entry-filename entry))
- (display ":")
- (display (entry-line entry))
- (newline)
- (display "@deffn procedure ")
- (display (entry-signature entry))
- (newline)
- (for-each (lambda (s) (write-line s))
- (entry-docstrings entry))
- (for-each (lambda (s) (display "@c ") (write-line s))
- (entry-options entry))
- (write-line "@end deffn"))
-
-;; Write an @var{entry} using plain format.
-;;-ttn-mod: renamed from `texinfo-output', distilled
-(define (format-plain entry)
- (display "Procedure: ")
- (display (entry-signature entry))
- (newline)
- (for-each (lambda (s) (write-line s))
- (entry-docstrings entry))
- (for-each (lambda (s) (display ";; ") (write-line s))
- (entry-options entry))
- (display "Snarfed from ")
- (display (entry-filename entry))
- (display ":")
- (display (entry-line entry))
- (newline)
- (write-line "\f"))
-
-;;; doc-snarf ends here
diff --git a/scripts/frisk b/scripts/frisk
deleted file mode 100755
index 108fc4a11..000000000
--- a/scripts/frisk
+++ /dev/null
@@ -1,292 +0,0 @@
-#!/bin/sh
-# aside from this initial boilerplate, this is actually -*- scheme -*- code
-main='(module-ref (resolve-module '\''(scripts frisk)) '\'main')'
-exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; frisk --- Grok the module interfaces of a body of files
-
-;; Copyright (C) 2002 Free Software Foundation, Inc.
-;;
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2, or
-;; (at your option) any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this software; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;; Boston, MA 02111-1307 USA
-
-;;; 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 *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)
- (note-use! 'regular module (ferret (cadr ls)))
- (loop (cddr ls)))
- ((: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/scripts/generate-autoload b/scripts/generate-autoload
deleted file mode 100755
index 942822ead..000000000
--- a/scripts/generate-autoload
+++ /dev/null
@@ -1,146 +0,0 @@
-#!/bin/sh
-# aside from this initial boilerplate, this is actually -*- scheme -*- code
-main='(module-ref (resolve-module '\''(scripts generate-autoload)) '\'main')'
-exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; generate-autoload --- Display define-module form with autoload info
-
-;; Copyright (C) 2001 Free Software Foundation, Inc.
-;;
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2, or
-;; (at your option) any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this software; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;; Boston, MA 02111-1307 USA
-
-;;; 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 (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/scripts/lint b/scripts/lint
deleted file mode 100755
index a43cfc065..000000000
--- a/scripts/lint
+++ /dev/null
@@ -1,319 +0,0 @@
-#!/bin/sh
-# aside from this initial boilerplate, this is actually -*- scheme -*- code
-main='(module-ref (resolve-module '\''(scripts lint)) '\'main')'
-exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; lint --- Preemptive checks for coding errors in Guile Scheme code
-
-;; Copyright (C) 2002 Free Software Foundation, Inc.
-;;
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2, or
-;; (at your option) any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this software; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;; Boston, MA 02111-1307 USA
-
-;;; 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.
-;;
-;; $ guile-tools lint `guile-tools`
-;; 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 (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))
- (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/scripts/punify b/scripts/punify
deleted file mode 100755
index eae8d51a7..000000000
--- a/scripts/punify
+++ /dev/null
@@ -1,89 +0,0 @@
-#!/bin/sh
-# aside from this initial boilerplate, this is actually -*- scheme -*- code
-main='(module-ref (resolve-module '\''(scripts punify)) '\'main')'
-exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; punify --- Display Scheme code w/o unnecessary comments / whitespace
-
-;; Copyright (C) 2001 Free Software Foundation, Inc.
-;;
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2, or
-;; (at your option) any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this software; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;; Boston, MA 02111-1307 USA
-
-;;; 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 (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/scripts/read-rfc822 b/scripts/read-rfc822
deleted file mode 100755
index 660f0feb9..000000000
--- a/scripts/read-rfc822
+++ /dev/null
@@ -1,133 +0,0 @@
-#!/bin/sh
-# aside from this initial boilerplate, this is actually -*- scheme -*- code
-main='(module-ref (resolve-module '\''(scripts read-rfc822)) '\'main')'
-exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; read-rfc822 --- Validate RFC822 file by displaying it to stdout
-
-;; Copyright (C) 2002 Free Software Foundation, Inc.
-;;
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2, or
-;; (at your option) any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this software; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;; Boston, MA 02111-1307 USA
-
-;;; 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 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 (cdr lines)
- (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/scripts/read-scheme-source b/scripts/read-scheme-source
deleted file mode 100755
index 31d851bd2..000000000
--- a/scripts/read-scheme-source
+++ /dev/null
@@ -1,284 +0,0 @@
-#!/bin/sh
-# aside from this initial boilerplate, this is actually -*- scheme -*- code
-main='(module-ref (resolve-module '\''(scripts read-scheme-source)) '\'main')'
-exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; read-scheme-source --- Read a file, recognizing scheme forms and comments
-
-;; Copyright (C) 2001 Free Software Foundation, Inc.
-;;
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2, or
-;; (at your option) any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this software; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;; Boston, MA 02111-1307 USA
-
-;;; 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))
-
-;; 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/scripts/read-text-outline b/scripts/read-text-outline
deleted file mode 100755
index 1a88f205e..000000000
--- a/scripts/read-text-outline
+++ /dev/null
@@ -1,255 +0,0 @@
-#!/bin/sh
-# aside from this initial boilerplate, this is actually -*- scheme -*- code
-main='(module-ref (resolve-module '\''(scripts read-text-outline)) '\'main')'
-exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; read-text-outline --- Read a text outline and display it as a sexp
-
-;; Copyright (C) 2002 Free Software Foundation, Inc.
-;;
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2, or
-;; (at your option) any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this software; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;; Boston, MA 02111-1307 USA
-
-;;; 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 (?? 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/scripts/scan-api b/scripts/scan-api
deleted file mode 100755
index 29837c8a2..000000000
--- a/scripts/scan-api
+++ /dev/null
@@ -1,225 +0,0 @@
-#!/bin/sh
-# aside from this initial boilerplate, this is actually -*- scheme -*- code
-main='(module-ref (resolve-module '\''(scripts scan-api)) '\'main')'
-exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; scan-api --- Scan and group interpreter and libguile interface elements
-
-;; Copyright (C) 2002 Free Software Foundation, Inc.
-;;
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2, or
-;; (at your option) any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this software; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;; Boston, MA 02111-1307 USA
-
-;;; 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 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/scripts/snarf-check-and-output-texi b/scripts/snarf-check-and-output-texi
deleted file mode 100755
index d669cab86..000000000
--- a/scripts/snarf-check-and-output-texi
+++ /dev/null
@@ -1,313 +0,0 @@
-#!/bin/sh
-# aside from this initial boilerplate, this is actually -*- scheme -*- code
-main="(module-ref (resolve-module '(scripts snarf-check-and-output-texi)) 'main)"
-exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; snarf-check-and-output-texi --- called by the doc snarfer.
-
-;; Copyright (C) 2001 Free Software Foundation, Inc.
-;;
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2, or
-;; (at your option) any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this software; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;; Boston, MA 02111-1307 USA
-
-;;; 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))
-
-;;; 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)
- ((eq? 'eol (stream-car s))
- (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* 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 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/scripts/snarf-guile-m4-docs b/scripts/snarf-guile-m4-docs
deleted file mode 100755
index 45d258c61..000000000
--- a/scripts/snarf-guile-m4-docs
+++ /dev/null
@@ -1,88 +0,0 @@
-#!/bin/sh
-# aside from this initial boilerplate, this is actually -*- scheme -*- code
-main='(module-ref (resolve-module '\''(scripts snarf-guile-m4-docs)) '\'main')'
-exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; snarf-guile-m4-docs --- Parse guile.m4 comments for texi documentation
-
-;; Copyright (C) 2002 Free Software Foundation, Inc.
-;;
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2, or
-;; (at your option) any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this software; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;; Boston, MA 02111-1307 USA
-
-;;; 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 (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/scripts/summarize-guile-TODO b/scripts/summarize-guile-TODO
deleted file mode 100755
index fb659c836..000000000
--- a/scripts/summarize-guile-TODO
+++ /dev/null
@@ -1,214 +0,0 @@
-#!/bin/sh
-# aside from this initial boilerplate, this is actually -*- scheme -*- code
-main='(module-ref (resolve-module '\''(scripts summarize-guile-TODO)) '\'main')'
-exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; summarize-guile-TODO --- Display Guile TODO list in various ways
-
-;; Copyright (C) 2002 Free Software Foundation, Inc.
-;;
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2, or
-;; (at your option) any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this software; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;; Boston, MA 02111-1307 USA
-
-;;; 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 'debug '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 (ice-9 common-list) (remove-if-not)
- :export (summarize-guile-TODO))
-
-(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 #\:))))))
- (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/scripts/use2dot b/scripts/use2dot
deleted file mode 100755
index dff341744..000000000
--- a/scripts/use2dot
+++ /dev/null
@@ -1,113 +0,0 @@
-#!/bin/sh
-# aside from this initial boilerplate, this is actually -*- scheme -*- code
-main='(module-ref (resolve-module '\''(scripts use2dot)) '\'main')'
-exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
-!#
-;;; use2dot --- Display module dependencies as a DOT specification
-
-;; Copyright (C) 2001 Free Software Foundation, Inc.
-;;
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation; either version 2, or
-;; (at your option) any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this software; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;; Boston, MA 02111-1307 USA
-
-;;; 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 *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