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