mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-02 21:10:27 +02:00
Code Activity

Still fixing screwups.

Browse source
This commit is contained in:
Rob Browning 2002-07-20 21:44:24 +00:00
parent 4304846e08
commit 8c81ca9fd2
10 changed files with 72 additions and 1115 deletions
Download patch file Download diff file Expand all files Collapse all files

2
scripts/.cvsignore Normal file
View file

@ -0,0 +1,2 @@
Makefile
Makefile.in

183
scripts/ChangeLog
View file

@ -1,134 +1,43 @@
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>
2002-03-24 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-03-14 Neil Jerram <neil@ossau.uklinux.net>
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.
* 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 to output.
(*primitive-deffnx-signature*, *primitive-deffnx-sig-length*):
Fluff to help insert the C declaration after any "@deffnx
{Scheme Procedure}" lines in the snarfed docstring.
* snarf-check-and-output-texi: Change generated @deffn categories
from "primitive" to "Scheme Procedure".
2002-03-05 Neil Jerram <neil@ossau.uklinux.net>
* Makefile.am (scripts_sources): Add `lint'.
* lint: New script.
* frisk (grok-proc): Handle `#:xxx' as well as `:xxx'.
2002-03-04 Rob Browning <rlb@defaultvalue.org>
* Makefile.am (scripts_sources): add snarf-guile-m4-docs.
2002-02-26 Thien-Thi Nguyen <ttn@giblet.glug.org>
* Makefile.am: Update path to pre-inst-guile automake frag.
@ -182,30 +91,6 @@
* 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.
@ -217,10 +102,6 @@
(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

8
scripts/Makefile.am
View file

@ -1,6 +1,6 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright (C) 2002 Free Software Foundation, Inc.
## Copyright (C) 2001 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@ -32,13 +32,9 @@ scripts_sources = \
lint \
punify \
read-scheme-source \
read-text-outline \
use2dot \
snarf-check-and-output-texi \
summarize-guile-TODO \
scan-api \
api-diff \
read-rfc822
snarf-guile-m4-docs
subpkgdatadir = $(pkgdatadir)/$(VERSION)/scripts
subpkgdata_SCRIPTS = $(scripts_sources)

161
scripts/api-diff
View file

@ -26,155 +26,60 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
;;; Commentary:
;; Usage: api-diff [-d GROUPS] ALIST-FILE-A ALIST-FILE-B
;;
;; Usage: api-diff 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.
;; and display four lists: old scheme, new scheme, old C, new C.
;;
;; For scheme programming, this module exports the proc:
;; For scheme programming, the (scripts api-diff) module exports
;; two procedures:
;; (diff-alists A-alist B-alist report)
;; (api-diff A-file B-file)
;; The latter implements the shell interface using the former.
;; REPORT is a proc that takes the above four lists. Its return
;; value is returned by `diff-alists'.
;;
;; Note that the convention is that the "older" alist/file is
;; specified first.
;;
;; TODO: Develop scheme interface.
;; TODO: When the annotations support it, also detect/report
;; procedure signature, or other simple type, changes.
;;; 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))
:export (diff-alists api-diff))
(define (read-alist-file file)
(with-input-from-file file
(lambda () (read))))
(define put set-object-property!)
(define get object-property)
(define (diff x y) (set-difference (map car x) (map car y)))
(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 (diff-alists A B report)
(let* ((A-scheme (assq-ref A 'scheme))
(A-C (assq-ref A 'C))
(B-scheme (assq-ref B 'scheme))
(B-C (assq-ref B 'C))
(OLD-scheme (diff A-scheme B-scheme))
(NEW-scheme (diff B-scheme A-scheme))
(OLD-C (diff A-C B-C))
(NEW-C (diff B-C A-C)))
(report OLD-scheme NEW-scheme OLD-C NEW-C)))
(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 (display-list head ls)
(format #t ":: ~A -- ~A\n" head (length ls))
(for-each (lambda (x) (format #t "~A\n" x)) ls)
(newline))
(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)))
(diff-alists (read-alist-file (list-ref args 0))
(read-alist-file (list-ref args 1))
(lambda (OLD-scheme NEW-scheme OLD-C NEW-C)
(display-list "OLD (deleted) scheme" OLD-scheme)
(display-list "NEW scheme" NEW-scheme)
(display-list "OLD (deleted) C" OLD-C)
(display-list "NEW C" NEW-C))))
(define main api-diff)

4
scripts/frisk
View file

@ -131,10 +131,10 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
(let loop ((ls form))
(or (null? ls)
(case (car ls)
((:use-module)
((:use-module #:use-module)
(note-use! 'regular module (ferret (cadr ls)))
(loop (cddr ls)))
((:autoload)
((:autoload #:autoload)
(note-use! 'autoload module (cadr ls))
(loop (cdddr ls)))
(else (loop (cdr ls))))))))

133
scripts/read-rfc822
View file

@ -1,133 +0,0 @@
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts read-rfc822)) '\'main')'
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; read-rfc822 --- Validate RFC822 file by displaying it to stdout
;; Copyright (C) 2002 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;; Boston, MA 02111-1307 USA
;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
;;; Commentary:
;; Usage: read-rfc822 FILE
;;
;; Read FILE, assumed to be in RFC822 format, and display it to stdout.
;; This is not very interesting, admittedly.
;;
;; For Scheme programming, this module exports two procs:
;; (read-rfc822 . args) ; only first arg used
;; (read-rfc822-silently port)
;;
;; Parse FILE (a string) or PORT, respectively, and return a query proc that
;; takes a symbol COMP, and returns the message component COMP. Supported
;; values for COMP (and the associated query return values) are:
;; from -- #f (reserved for future mbox support)
;; headers -- alist of (HEADER-SYMBOL . "VALUE-STRING") pairs, in order
;; body -- rest of the mail message, a string
;; body-lines -- rest of the mail message, as a list of lines
;; Any other query results in a "bad component" error.
;;
;; TODO: Add "-m" option (mbox support).
;;; Code:
(define-module (scripts read-rfc822)
:use-module (ice-9 regex)
:use-module (ice-9 rdelim)
:autoload (srfi srfi-13) (string-join)
:export (read-rfc822 read-rfc822-silently))
(define from-line-rx (make-regexp "^From "))
(define header-name-rx (make-regexp "^([^:]+):[ \t]*"))
(define header-cont-rx (make-regexp "^[ \t]+"))
(define option #f) ; for future "-m"
(define (drain-message port)
(let loop ((line (read-line port)) (acc '()))
(cond ((eof-object? line)
(reverse acc))
((and option (regexp-exec from-line-rx line))
(for-each (lambda (c)
(unread-char c port))
(cons #\newline
(reverse (string->list line))))
(reverse acc))
(else
(loop (read-line port) (cons line acc))))))
(define (parse-message port)
(let* ((from (and option
(match:suffix (regexp-exec from-line-rx
(read-line port)))))
(body-lines #f)
(body #f)
(headers '())
(add-header! (lambda (reversed-hlines)
(let* ((hlines (reverse reversed-hlines))
(first (car hlines))
(m (regexp-exec header-name-rx first))
(name (string->symbol (match:substring m 1)))
(data (string-join
(cons (substring first (match:end m))
(cdr hlines))
" ")))
(set! headers (acons name data headers))))))
;; "From " is only one line
(let loop ((line (read-line port)) (current-header #f))
(cond ((string-null? line)
(and current-header (add-header! current-header))
(set! body-lines (drain-message port)))
((regexp-exec header-cont-rx line)
=> (lambda (m)
(loop (cdr lines)
(cons (match:suffix m) current-header))))
(else
(and current-header (add-header! current-header))
(loop (read-line port) (list line)))))
(set! headers (reverse headers))
(lambda (component)
(case component
((from) from)
((body-lines) body-lines)
((headers) headers)
((body) (or body
(begin (set! body (string-join body-lines "\n" 'suffix))
body)))
(else (error "bad component:" component))))))
(define (read-rfc822-silently port)
(parse-message port))
(define (display-rfc822 parse)
(cond ((parse 'from) => (lambda (from) (format #t "From ~A\n" from))))
(for-each (lambda (header)
(format #t "~A: ~A\n" (car header) (cdr header)))
(parse 'headers))
(format #t "\n~A" (parse 'body)))
(define (read-rfc822 . args)
(let ((parse (read-rfc822-silently (open-file (car args) OPEN_READ))))
(display-rfc822 parse))
#t)
(define main read-rfc822)
;;; read-rfc822 ends here

255
scripts/read-text-outline
View file

@ -1,255 +0,0 @@
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts read-text-outline)) '\'main')'
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; read-text-outline --- Read a text outline and display it as a sexp
;; Copyright (C) 2002 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;; Boston, MA 02111-1307 USA
;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
;;; Commentary:
;; Usage: read-text-outline OUTLINE
;;
;; Scan OUTLINE file and display a list of trees, the structure of
;; each reflecting the "levels" in OUTLINE. The recognized outline
;; format (used to indicate outline headings) is zero or more pairs of
;; leading spaces followed by "-". Something like:
;;
;; - a 0
;; - b 1
;; - c 2
;; - d 1
;; - e 0
;; - f 1
;; - g 2
;; - h 1
;;
;; In this example the levels are shown to the right. The output for
;; such a file would be the single line:
;;
;; (("a" ("b" "c") "d") ("e" ("f" "g") "h"))
;;
;; Basically, anything at the beginning of a list is a parent, and the
;; remaining elements of that list are its children.
;;
;;
;; Usage from a Scheme program: These two procs are exported:
;;
;; (read-text-outline . args) ; only first arg is used
;; (read-text-outline-silently port)
;; (make-text-outline-reader re specs)
;;
;; `make-text-outline-reader' returns a proc that reads from PORT and
;; returns a list of trees (similar to `read-text-outline-silently').
;;
;; RE is a regular expression (string) that is used to identify a header
;; line of the outline (as opposed to a whitespace line or intervening
;; text). RE must begin w/ a sub-expression to match the "level prefix"
;; of the line. You can use `level-submatch-number' in SPECS (explained
;; below) to specify a number other than 1, the default.
;;
;; Normally, the level of the line is taken directly as the length of
;; its level prefix. This often results in adjacent levels not mapping
;; to adjacent numbers, which confuses the tree-building portion of the
;; program, which expects top-level to be 0, first sub-level to be 1,
;; etc. You can use `level-substring-divisor' or `compute-level' in
;; SPECS to specify a constant scaling factor or specify a completely
;; alternative procedure, respectively.
;;
;; SPECS is an alist which may contain the following key/value pairs:
;;
;; - level-submatch-number NUMBER
;; - level-substring-divisor NUMBER
;; - compute-level PROC
;; - body-submatch-number NUMBER
;; - extra-fields ((FIELD-1 . SUBMATCH-1) (FIELD-2 . SUBMATCH-2) ...)
;;
;; The PROC value associated with key `compute-level' should take a
;; Scheme match structure (as returned by `regexp-exec') and return a
;; number, the normalized level for that line. If this is specified,
;; it takes precedence over other level-computation methods.
;;
;; Use `body-submatch-number' if RE specifies the whole body, or if you
;; want to make use of the extra fields parsing. The `extra-fields'
;; value is a sub-alist, whose keys name additional fields that are to
;; be recognized. These fields along with `level' are set as object
;; properties of the final string ("body") that is consed into the tree.
;; If a field name ends in "?" the field value is set to be #t if there
;; is a match and the result is not an empty string, and #f otherwise.
;;
;;
;; Bugs and caveats:
;;
;; (1) Only the first file specified on the command line is scanned.
;; (2) TAB characters at the beginnings of lines are not recognized.
;; (3) Outlines that "skip" levels signal an error. In other words,
;; this will fail:
;;
;; - a 0
;; - b 1
;; - c 3 <-- skipped 2 -- error!
;; - d 1
;;
;;
;; TODO: Determine what's the right thing to do for skips.
;; Handle TABs.
;; Make line format customizable via longopts.
;;; Code:
(define-module (scripts read-text-outline)
:export (read-text-outline
read-text-outline-silently
make-text-outline-reader)
:use-module (ice-9 regex)
:autoload (ice-9 rdelim) (read-line)
:autoload (ice-9 getopt-long) (getopt-long))
(define (?? symbol)
(let ((name (symbol->string symbol)))
(string=? "?" (substring name (1- (string-length name))))))
(define (msub n)
(lambda (m)
(match:substring m n)))
(define (??-predicates pair)
(cons (car pair)
(if (?? (car pair))
(lambda (m)
(not (string=? "" (match:substring m (cdr pair)))))
(msub (cdr pair)))))
(define (make-line-parser re specs)
(let* ((rx (let ((fc (substring re 0 1)))
(make-regexp (if (string=? "^" fc)
re
(string-append "^" re)))))
(check (lambda (key)
(assq-ref specs key)))
(level-substring (msub (or (check 'level-submatch-number) 1)))
(extract-level (cond ((check 'compute-level)
=> (lambda (proc)
(lambda (m)
(proc m))))
((check 'level-substring-divisor)
=> (lambda (n)
(lambda (m)
(/ (string-length (level-substring m))
n))))
(else
(lambda (m)
(string-length (level-substring m))))))
(extract-body (cond ((check 'body-submatch-number)
=> msub)
(else
(lambda (m) (match:suffix m)))))
(misc-props! (cond ((check 'extra-fields)
=> (lambda (alist)
(let ((new (map ??-predicates alist)))
(lambda (obj m)
(for-each
(lambda (pair)
(set-object-property!
obj (car pair)
((cdr pair) m)))
new)))))
(else
(lambda (obj m) #t)))))
;; retval
(lambda (line)
(cond ((regexp-exec rx line)
=> (lambda (m)
(let ((level (extract-level m))
(body (extract-body m)))
(set-object-property! body 'level level)
(misc-props! body m)
body)))
(else #f)))))
(define (make-text-outline-reader re specs)
(let ((parse-line (make-line-parser re specs)))
;; retval
(lambda (port)
(let* ((all '(start))
(pchain (list))) ; parents chain
(let loop ((line (read-line port))
(prev-level -1) ; how this relates to the first input
; level determines whether or not we
; start in "sibling" or "child" mode.
; in the end, `start' is ignored and
; it's much easier to ignore parents
; than siblings (sometimes). this is
; not to encourage ignorance, however.
(tp all)) ; tail pointer
(or (eof-object? line)
(cond ((parse-line line)
=> (lambda (w)
(let* ((words (list w))
(level (object-property w 'level))
(diff (- level prev-level)))
(cond
;; sibling
((zero? diff)
;; just extend the chain
(set-cdr! tp words))
;; child
((positive? diff)
(or (= 1 diff)
(error "unhandled diff not 1:" diff line))
;; parent may be contacted by uncle later (kids
;; these days!) so save its level
(set-object-property! tp 'level prev-level)
(set! pchain (cons tp pchain))
;; "push down" car into hierarchy
(set-car! tp (cons (car tp) words)))
;; uncle
((negative? diff)
;; prune back to where levels match
(do ((p pchain (cdr p)))
((= level (object-property (car p) 'level))
(set! pchain p)))
;; resume at this level
(set-cdr! (car pchain) words)
(set! pchain (cdr pchain))))
(loop (read-line port) level words))))
(else (loop (read-line port) prev-level tp)))))
(set! all (car all))
(if (eq? 'start all)
'() ; wasteland
(cdr all))))))
(define read-text-outline-silently
(make-text-outline-reader "(([ ][ ])*)- *"
'((level-substring-divisor . 2))))
(define (read-text-outline . args)
(write (read-text-outline-silently (open-file (car args) "r")))
(newline)
#t) ; exit val
(define main read-text-outline)
;;; read-text-outline ends here

225
scripts/scan-api
View file

@ -1,225 +0,0 @@
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts scan-api)) '\'main')'
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; scan-api --- Scan and group interpreter and libguile interface elements
;; Copyright (C) 2002 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;; Boston, MA 02111-1307 USA
;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
;;; Commentary:
;; Usage: scan-api GUILE SOFILE [GROUPINGS ...]
;;
;; Invoke GUILE, an executable guile interpreter, and use nm(1) on SOFILE, a
;; shared-object library, to determine available interface elements, and
;; display them to stdout as an alist:
;;
;; ((meta ...) (interface ...))
;;
;; The meta fields are `GUILE_LOAD_PATH', `LTDL_LIBRARY_PATH', `guile'
;; `libguileinterface', `sofile' and `groups'. The interface elements are in
;; turn sub-alists w/ keys `groups' and `scan-data'. Interface elements
;; initially belong in one of two groups `Scheme' or `C' (but not both --
;; signal error if that happens).
;;
;; Optional GROUPINGS ... are files each containing a single "grouping
;; definition" alist with each entry of the form:
;;
;; (NAME (description "DESCRIPTION") (members SYM...))
;;
;; All of the SYM... should be proper subsets of the interface. In addition
;; to `description' and `members' forms, the entry may optionally include:
;;
;; (grok USE-MODULES (lambda (x) CODE))
;;
;; where CODE implements a group-membership predicate to be applied to `x', a
;; symbol. [When evaluated, CODE can assume (use-modules MODULE) has been
;; executed where MODULE is an element of USE-MODULES, a list. [NOT YET
;; IMPLEMENTED!]]
;;
;; Currently, there are two convenience predicates that operate on `x':
;; (in-group? x GROUP)
;; (name-prefix? x PREFIX)
;;
;; TODO: Allow for concurrent Scheme/C membership.
;; Completely separate reporting.
;;; Code:
(define-module (scripts scan-api)
:use-module (ice-9 popen)
:use-module (ice-9 rdelim)
:use-module (ice-9 regex)
:export (scan-api))
(define put set-object-property!)
(define get object-property)
(define (add-props object . args)
(let loop ((args args))
(if (null? args)
object ; retval
(let ((key (car args))
(value (cadr args)))
(put object key value)
(loop (cddr args))))))
(define (scan re command match)
(let ((rx (make-regexp re))
(port (open-pipe command OPEN_READ)))
(let loop ((line (read-line port)))
(or (eof-object? line)
(begin
(cond ((regexp-exec rx line) => match))
(loop (read-line port)))))))
(define (scan-Scheme! ht guile)
(scan "^.guile.+: ([^ \t]+)([ \t]+(.+))*$"
(format #f "~A -c '~S ~S'"
guile
'(use-modules (ice-9 session))
'(apropos "."))
(lambda (m)
(let ((x (string->symbol (match:substring m 1))))
(put x 'Scheme (or (match:substring m 3)
""))
(hashq-set! ht x #t)))))
(define (scan-C! ht sofile)
(scan "^[0-9a-fA-F]+ ([B-TV-Z]) (.+)$"
(format #f "nm ~A" sofile)
(lambda (m)
(let ((x (string->symbol (match:substring m 2))))
(put x 'C (string->symbol (match:substring m 1)))
(and (hashq-get-handle ht x)
(error "both Scheme and C:" x))
(hashq-set! ht x #t)))))
(define THIS-MODULE (current-module))
(define (in-group? x group)
(memq group (get x 'groups)))
(define (name-prefix? x prefix)
(string-match (string-append "^" prefix) (symbol->string x)))
(define (add-group-name! x name)
(put x 'groups (cons name (get x 'groups))))
(define (make-grok-proc name form)
(let* ((predicate? (eval form THIS-MODULE))
(p (lambda (x)
(and (predicate? x)
(add-group-name! x name)))))
(put p 'name name)
p))
(define (make-members-proc name members)
(let ((p (lambda (x)
(and (memq x members)
(add-group-name! x name)))))
(put p 'name name)
p))
(define (make-grouper files) ; \/^^^o/ . o
(let ((hook (make-hook 1))) ; /\____\
(for-each
(lambda (file)
(for-each
(lambda (gdef)
(let ((name (car gdef))
(members (assq-ref gdef 'members))
(grok (assq-ref gdef 'grok)))
(or members grok
(error "bad grouping, must have `members' or `grok'"))
(add-hook! hook
(if grok
(add-props (make-grok-proc name (cadr grok))
'description
(assq-ref gdef 'description))
(make-members-proc name members))
#t))) ; append
(read (open-file file OPEN_READ))))
files)
hook))
(define (scan-api . args)
(let ((guile (list-ref args 0))
(sofile (list-ref args 1))
(grouper (false-if-exception (make-grouper (cddr args))))
(ht (make-hash-table 3331)))
(scan-Scheme! ht guile)
(scan-C! ht sofile)
(let ((all (sort (hash-fold (lambda (key value prior-result)
(add-props
key
'string (symbol->string key)
'scan-data (or (get key 'Scheme)
(get key 'C))
'groups (if (get key 'Scheme)
'(Scheme)
'(C)))
(and grouper (run-hook grouper key))
(cons key prior-result))
'()
ht)
(lambda (a b)
(string<? (get a 'string)
(get b 'string))))))
(format #t ";;; generated by scan-api -- do not edit!\n\n")
(format #t "(\n")
(format #t "(meta\n")
(format #t " (GUILE_LOAD_PATH . ~S)\n"
(or (getenv "GUILE_LOAD_PATH") ""))
(format #t " (LTDL_LIBRARY_PATH . ~S)\n"
(or (getenv "LTDL_LIBRARY_PATH") ""))
(format #t " (guile . ~S)\n" guile)
(format #t " (libguileinterface . ~S)\n"
(let ((i #f))
(scan "(.+)"
(format #f "~A -c '(display ~A)'"
guile
'(assq-ref %guile-build-info
'libguileinterface))
(lambda (m) (set! i (match:substring m 1))))
i))
(format #t " (sofile . ~S)\n" sofile)
(format #t " ~A\n"
(cons 'groups (append (if grouper
(map (lambda (p) (get p 'name))
(hook->list grouper))
'())
'(Scheme C))))
(format #t ") ;; end of meta\n")
(format #t "(interface\n")
(for-each (lambda (x)
(format #t "(~A ~A (scan-data ~S))\n"
x
(cons 'groups (get x 'groups))
(get x 'scan-data)))
all)
(format #t ") ;; end of interface\n")
(format #t ") ;; eof\n")))
#t)
(define main scan-api)
;;; scan-api ends here

214
scripts/summarize-guile-TODO
View file

@ -1,214 +0,0 @@
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts summarize-guile-TODO)) '\'main')'
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; summarize-guile-TODO --- Display Guile TODO list in various ways
;; Copyright (C) 2002 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;; Boston, MA 02111-1307 USA
;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
;;; Commentary:
;; Usage: summarize-guile-TODO TODOFILE
;;
;; The TODOFILE is typically Guile's (see workbook/tasks/README)
;; presumed to serve as our signal to ourselves (lest we want real
;; bosses hassling us) wrt to the overt message "items to do" as well as
;; the messages that can be inferred from its structure.
;;
;; This program reads TODOFILE and displays interpretations on its
;; structure, including registered markers and ownership, in various
;; ways.
;;
;; A primary interest in any task is its parent task. The output
;; summarization by default lists every item and its parent chain.
;; Top-level parents are not items. You can use these command-line
;; options to modify the selection and display (selection criteria
;; are ANDed together):
;;
;; -i, --involved USER -- select USER-involved items
;; -p, --personal USER -- select USER-responsible items
;; -t, --todo -- select unfinished items (status "-")
;; -d, --done -- select finished items (status "+")
;; -r, --review -- select review items (marker "R")
;;
;; -w, --who -- also show who is associated w/ the item
;; -n, --no-parent -- do not show parent chain
;;
;;
;; Usage from a Scheme program:
;; (summarize-guile-TODO . args) ; uses first arg only
;;
;;
;; Bugs: (1) Markers are scanned in sequence: D R X N%. This means "XD"
;; and the like are completely dropped. However, such strings
;; are unlikely to be used if the markers are chosen to be
;; somewhat exclusive, which is currently the case for D R X.
;; N% used w/ these needs to be something like: "D25%" (this
;; means discussion accounts for 1/4 of the task).
;;
;; TODO: Implement more various ways. (Patches welcome.)
;; Add support for ORing criteria.
;;; Code:
(debug-enable 'debug 'backtrace)
(define-module (scripts summarize-guile-TODO)
:use-module (scripts read-text-outline)
:use-module (ice-9 getopt-long)
:autoload (srfi srfi-13) (string-tokenize) ; string library
:autoload (ice-9 common-list) (remove-if-not)
:export (summarize-guile-TODO))
(define put set-object-property!)
(define get object-property)
(define (as-leaf x)
(cond ((get x 'who)
=> (lambda (who)
(put x 'who
(map string->symbol
(string-tokenize who #\:))))))
(cond ((get x 'pct-done)
=> (lambda (pct-done)
(put x 'pct-done (string->number pct-done)))))
x)
(define (hang-by-the-leaves trees)
(let ((leaves '()))
(letrec ((hang (lambda (tree parent)
(if (list? tree)
(begin
(put (car tree) 'parent parent)
(for-each (lambda (child)
(hang child (car tree)))
(cdr tree)))
(begin
(put tree 'parent parent)
(set! leaves (cons (as-leaf tree) leaves)))))))
(for-each (lambda (tree)
(hang tree #f))
trees))
leaves))
(define (read-TODO file)
(hang-by-the-leaves
((make-text-outline-reader
"(([ ][ ])*)([-+])(D*)(R*)(X*)(([0-9]+)%)* *([^[]*)(\\[(.*)\\])*"
'((level-substring-divisor . 2)
(body-submatch-number . 9)
(extra-fields . ((status . 3)
(design? . 4)
(review? . 5)
(extblock? . 6)
(pct-done . 8)
(who . 11)))))
(open-file file "r"))))
(define (select-items p items)
(let ((sub '()))
(cond ((option-ref p 'involved #f)
=> (lambda (u)
(let ((u (string->symbol u)))
(set! sub (cons
(lambda (x)
(and (get x 'who)
(memq u (get x 'who))))
sub))))))
(cond ((option-ref p 'personal #f)
=> (lambda (u)
(let ((u (string->symbol u)))
(set! sub (cons
(lambda (x)
(cond ((get x 'who)
=> (lambda (ls)
(eq? (car (reverse ls))
u)))
(else #f)))
sub))))))
(for-each (lambda (pair)
(cond ((option-ref p (car pair) #f)
(set! sub (cons (cdr pair) sub)))))
`((todo . ,(lambda (x) (string=? (get x 'status) "-")))
(done . ,(lambda (x) (string=? (get x 'status) "+")))
(review . ,(lambda (x) (get x 'review?)))))
(let loop ((sub (reverse sub)) (items items))
(if (null? sub)
(reverse items)
(loop (cdr sub) (remove-if-not (car sub) items))))))
(define (make-display-item show-who? show-parent?)
(let ((show-who
(if show-who?
(lambda (item)
(cond ((get item 'who)
=> (lambda (who) (format #f " ~A" who)))
(else "")))
(lambda (item) "")))
(show-parents
(if show-parent?
(lambda (item)
(let loop ((parent (get item 'parent)) (indent 2))
(and parent
(begin
(format #t "under : ~A~A\n"
(make-string indent #\space)
parent)
(loop (get parent 'parent) (+ 2 indent))))))
(lambda (item) #t))))
(lambda (item)
(format #t "status: ~A~A~A~A~A~A\nitem : ~A\n"
(get item 'status)
(if (get item 'design?) "D" "")
(if (get item 'review?) "R" "")
(if (get item 'extblock?) "X" "")
(cond ((get item 'pct-done)
=> (lambda (pct-done)
(format #f " ~A%" pct-done)))
(else ""))
(show-who item)
item)
(show-parents item))))
(define (display-items p items)
(let ((display-item (make-display-item (option-ref p 'who #f)
(not (option-ref p 'no-parent #f))
)))
(for-each display-item items)))
(define (summarize-guile-TODO . args)
(let ((p (getopt-long (cons "summarize-guile-TODO" args)
'((who (single-char #\w))
(no-parent (single-char #\n))
(involved (single-char #\i)
(value #t))
(personal (single-char #\p)
(value #t))
(todo (single-char #\t))
(done (single-char #\d))
(review (single-char #\r))
;; Add options here.
))))
(display-items p (select-items p (read-TODO (car (option-ref p '() #f))))))
#t) ; exit val
(define main summarize-guile-TODO)
;;; summarize-guile-TODO ends here