diff options
Diffstat (limited to 'scripts')
-rw-r--r-- | scripts/.cvsignore | 2 | ||||
-rw-r--r-- | scripts/ChangeLog | 286 | ||||
-rw-r--r-- | scripts/Makefile.am | 67 | ||||
-rwxr-xr-x | scripts/PROGRAM | 45 | ||||
-rw-r--r-- | scripts/README | 76 | ||||
-rwxr-xr-x | scripts/api-diff | 181 | ||||
-rwxr-xr-x | scripts/autofrisk | 221 | ||||
-rwxr-xr-x | scripts/display-commentary | 70 | ||||
-rwxr-xr-x | scripts/doc-snarf | 442 | ||||
-rwxr-xr-x | scripts/frisk | 292 | ||||
-rwxr-xr-x | scripts/generate-autoload | 146 | ||||
-rwxr-xr-x | scripts/lint | 319 | ||||
-rwxr-xr-x | scripts/punify | 89 | ||||
-rwxr-xr-x | scripts/read-rfc822 | 133 | ||||
-rwxr-xr-x | scripts/read-scheme-source | 284 | ||||
-rwxr-xr-x | scripts/read-text-outline | 255 | ||||
-rwxr-xr-x | scripts/scan-api | 225 | ||||
-rwxr-xr-x | scripts/snarf-check-and-output-texi | 313 | ||||
-rwxr-xr-x | scripts/snarf-guile-m4-docs | 88 | ||||
-rwxr-xr-x | scripts/summarize-guile-TODO | 214 | ||||
-rwxr-xr-x | scripts/use2dot | 113 |
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 |