From 8c81ca9fd2381bb6c982eeea6dc224e84d82643f Mon Sep 17 00:00:00 2001 From: Rob Browning Date: Sat, 20 Jul 2002 21:44:24 +0000 Subject: [PATCH] Still fixing screwups. --- scripts/.cvsignore | 2 + scripts/ChangeLog | 183 +++++-------------------- scripts/Makefile.am | 8 +- scripts/api-diff | 161 +++++----------------- scripts/frisk | 4 +- scripts/lint | 2 +- scripts/read-rfc822 | 133 ------------------ scripts/read-text-outline | 255 ----------------------------------- scripts/scan-api | 225 ------------------------------- scripts/summarize-guile-TODO | 214 ----------------------------- 10 files changed, 72 insertions(+), 1115 deletions(-) create mode 100644 scripts/.cvsignore delete mode 100755 scripts/read-rfc822 delete mode 100755 scripts/read-text-outline delete mode 100755 scripts/scan-api delete mode 100755 scripts/summarize-guile-TODO diff --git a/scripts/.cvsignore b/scripts/.cvsignore new file mode 100644 index 000000000..282522db0 --- /dev/null +++ b/scripts/.cvsignore @@ -0,0 +1,2 @@ +Makefile +Makefile.in diff --git a/scripts/ChangeLog b/scripts/ChangeLog index e6b36f8f1..2fd8502b8 100644 --- a/scripts/ChangeLog +++ b/scripts/ChangeLog @@ -1,134 +1,43 @@ -2002-05-18 Thien-Thi Nguyen - - * api-diff (group-diff): Also output +N and -N adds and subs - details, respectively. - -2002-05-13 Thien-Thi Nguyen - - * 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 - - * 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 - - * 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 - - * scan-api (scan-C!): Use more robust regexp. - -2002-05-08 Thien-Thi Nguyen - - * 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 - - * summarize-guile-TODO (make-display-item): - Hoist some lambdas; nfc. - -2002-04-29 Thien-Thi Nguyen - - * summarize-guile-TODO: Fix commentary typo; nfc. - -2002-04-08 Thien-Thi Nguyen - - * 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 - - * 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 - - * summarize-guile-TODO: New script. - - * Makefile.am (scripts_sources): Add "summarize-guile-TODO". - -2002-04-05 Thien-Thi Nguyen - - * 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 - - * lint: New script. - - * Makefile.am (scripts_sources): Add "lint". - 2002-04-02 Thien-Thi Nguyen * 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 - - * 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 +2002-03-24 Neil Jerram * snarf-guile-m4-docs (display-texi): Strip off `# ' from start of docstring lines if possible, rather than just `#'. +2002-03-14 Neil Jerram + + 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 + + * Makefile.am (scripts_sources): Add `lint'. + + * lint: New script. + + * frisk (grok-proc): Handle `#:xxx' as well as `:xxx'. + +2002-03-04 Rob Browning + + * Makefile.am (scripts_sources): add snarf-guile-m4-docs. + 2002-02-26 Thien-Thi Nguyen * 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 - - * 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 * 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 - - * Makefile.am (AUTOMAKE_OPTIONS): Change "foreign" to "gnu". - 2001-08-07 Michael Livshin * snarf-check-and-output-texi: print optional args in a prettier diff --git a/scripts/Makefile.am b/scripts/Makefile.am index 46d1885d0..7c83b895b 100644 --- a/scripts/Makefile.am +++ b/scripts/Makefile.am @@ -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) diff --git a/scripts/api-diff b/scripts/api-diff index 433ff0f45..76e8d8582 100755 --- a/scripts/api-diff +++ b/scripts/api-diff @@ -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) - (stringstring 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) diff --git a/scripts/frisk b/scripts/frisk index 108fc4a11..183339f24 100755 --- a/scripts/frisk +++ b/scripts/frisk @@ -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)))))))) diff --git a/scripts/lint b/scripts/lint index a43cfc065..a4486a81a 100755 --- a/scripts/lint +++ b/scripts/lint @@ -287,7 +287,7 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" (map (lambda (case) (detect-free-variables (cdr case) locals)) (cddr x)))) - + ((unquote unquote-splicing else =>) (detect-free-variables-noncar (cdr x) locals)) diff --git a/scripts/read-rfc822 b/scripts/read-rfc822 deleted file mode 100755 index 660f0feb9..000000000 --- a/scripts/read-rfc822 +++ /dev/null @@ -1,133 +0,0 @@ -#!/bin/sh -# aside from this initial boilerplate, this is actually -*- scheme -*- code -main='(module-ref (resolve-module '\''(scripts read-rfc822)) '\'main')' -exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" -!# -;;; read-rfc822 --- Validate RFC822 file by displaying it to stdout - -;; Copyright (C) 2002 Free Software Foundation, Inc. -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;; Boston, MA 02111-1307 USA - -;;; Author: Thien-Thi Nguyen - -;;; Commentary: - -;; Usage: read-rfc822 FILE -;; -;; Read FILE, assumed to be in RFC822 format, and display it to stdout. -;; This is not very interesting, admittedly. -;; -;; For Scheme programming, this module exports two procs: -;; (read-rfc822 . args) ; only first arg used -;; (read-rfc822-silently port) -;; -;; Parse FILE (a string) or PORT, respectively, and return a query proc that -;; takes a symbol COMP, and returns the message component COMP. Supported -;; values for COMP (and the associated query return values) are: -;; from -- #f (reserved for future mbox support) -;; headers -- alist of (HEADER-SYMBOL . "VALUE-STRING") pairs, in order -;; body -- rest of the mail message, a string -;; body-lines -- rest of the mail message, as a list of lines -;; Any other query results in a "bad component" error. -;; -;; TODO: Add "-m" option (mbox support). - -;;; Code: - -(define-module (scripts read-rfc822) - :use-module (ice-9 regex) - :use-module (ice-9 rdelim) - :autoload (srfi srfi-13) (string-join) - :export (read-rfc822 read-rfc822-silently)) - -(define from-line-rx (make-regexp "^From ")) -(define header-name-rx (make-regexp "^([^:]+):[ \t]*")) -(define header-cont-rx (make-regexp "^[ \t]+")) - -(define option #f) ; for future "-m" - -(define (drain-message port) - (let loop ((line (read-line port)) (acc '())) - (cond ((eof-object? line) - (reverse acc)) - ((and option (regexp-exec from-line-rx line)) - (for-each (lambda (c) - (unread-char c port)) - (cons #\newline - (reverse (string->list line)))) - (reverse acc)) - (else - (loop (read-line port) (cons line acc)))))) - -(define (parse-message port) - (let* ((from (and option - (match:suffix (regexp-exec from-line-rx - (read-line port))))) - (body-lines #f) - (body #f) - (headers '()) - (add-header! (lambda (reversed-hlines) - (let* ((hlines (reverse reversed-hlines)) - (first (car hlines)) - (m (regexp-exec header-name-rx first)) - (name (string->symbol (match:substring m 1))) - (data (string-join - (cons (substring first (match:end m)) - (cdr hlines)) - " "))) - (set! headers (acons name data headers)))))) - ;; "From " is only one line - (let loop ((line (read-line port)) (current-header #f)) - (cond ((string-null? line) - (and current-header (add-header! current-header)) - (set! body-lines (drain-message port))) - ((regexp-exec header-cont-rx line) - => (lambda (m) - (loop (cdr lines) - (cons (match:suffix m) current-header)))) - (else - (and current-header (add-header! current-header)) - (loop (read-line port) (list line))))) - (set! headers (reverse headers)) - (lambda (component) - (case component - ((from) from) - ((body-lines) body-lines) - ((headers) headers) - ((body) (or body - (begin (set! body (string-join body-lines "\n" 'suffix)) - body))) - (else (error "bad component:" component)))))) - -(define (read-rfc822-silently port) - (parse-message port)) - -(define (display-rfc822 parse) - (cond ((parse 'from) => (lambda (from) (format #t "From ~A\n" from)))) - (for-each (lambda (header) - (format #t "~A: ~A\n" (car header) (cdr header))) - (parse 'headers)) - (format #t "\n~A" (parse 'body))) - -(define (read-rfc822 . args) - (let ((parse (read-rfc822-silently (open-file (car args) OPEN_READ)))) - (display-rfc822 parse)) - #t) - -(define main read-rfc822) - -;;; read-rfc822 ends here diff --git a/scripts/read-text-outline b/scripts/read-text-outline deleted file mode 100755 index 1a88f205e..000000000 --- a/scripts/read-text-outline +++ /dev/null @@ -1,255 +0,0 @@ -#!/bin/sh -# aside from this initial boilerplate, this is actually -*- scheme -*- code -main='(module-ref (resolve-module '\''(scripts read-text-outline)) '\'main')' -exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" -!# -;;; read-text-outline --- Read a text outline and display it as a sexp - -;; Copyright (C) 2002 Free Software Foundation, Inc. -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;; Boston, MA 02111-1307 USA - -;;; Author: Thien-Thi Nguyen - -;;; Commentary: - -;; Usage: read-text-outline OUTLINE -;; -;; Scan OUTLINE file and display a list of trees, the structure of -;; each reflecting the "levels" in OUTLINE. The recognized outline -;; format (used to indicate outline headings) is zero or more pairs of -;; leading spaces followed by "-". Something like: -;; -;; - a 0 -;; - b 1 -;; - c 2 -;; - d 1 -;; - e 0 -;; - f 1 -;; - g 2 -;; - h 1 -;; -;; In this example the levels are shown to the right. The output for -;; such a file would be the single line: -;; -;; (("a" ("b" "c") "d") ("e" ("f" "g") "h")) -;; -;; Basically, anything at the beginning of a list is a parent, and the -;; remaining elements of that list are its children. -;; -;; -;; Usage from a Scheme program: These two procs are exported: -;; -;; (read-text-outline . args) ; only first arg is used -;; (read-text-outline-silently port) -;; (make-text-outline-reader re specs) -;; -;; `make-text-outline-reader' returns a proc that reads from PORT and -;; returns a list of trees (similar to `read-text-outline-silently'). -;; -;; RE is a regular expression (string) that is used to identify a header -;; line of the outline (as opposed to a whitespace line or intervening -;; text). RE must begin w/ a sub-expression to match the "level prefix" -;; of the line. You can use `level-submatch-number' in SPECS (explained -;; below) to specify a number other than 1, the default. -;; -;; Normally, the level of the line is taken directly as the length of -;; its level prefix. This often results in adjacent levels not mapping -;; to adjacent numbers, which confuses the tree-building portion of the -;; program, which expects top-level to be 0, first sub-level to be 1, -;; etc. You can use `level-substring-divisor' or `compute-level' in -;; SPECS to specify a constant scaling factor or specify a completely -;; alternative procedure, respectively. -;; -;; SPECS is an alist which may contain the following key/value pairs: -;; -;; - level-submatch-number NUMBER -;; - level-substring-divisor NUMBER -;; - compute-level PROC -;; - body-submatch-number NUMBER -;; - extra-fields ((FIELD-1 . SUBMATCH-1) (FIELD-2 . SUBMATCH-2) ...) -;; -;; The PROC value associated with key `compute-level' should take a -;; Scheme match structure (as returned by `regexp-exec') and return a -;; number, the normalized level for that line. If this is specified, -;; it takes precedence over other level-computation methods. -;; -;; Use `body-submatch-number' if RE specifies the whole body, or if you -;; want to make use of the extra fields parsing. The `extra-fields' -;; value is a sub-alist, whose keys name additional fields that are to -;; be recognized. These fields along with `level' are set as object -;; properties of the final string ("body") that is consed into the tree. -;; If a field name ends in "?" the field value is set to be #t if there -;; is a match and the result is not an empty string, and #f otherwise. -;; -;; -;; Bugs and caveats: -;; -;; (1) Only the first file specified on the command line is scanned. -;; (2) TAB characters at the beginnings of lines are not recognized. -;; (3) Outlines that "skip" levels signal an error. In other words, -;; this will fail: -;; -;; - a 0 -;; - b 1 -;; - c 3 <-- skipped 2 -- error! -;; - d 1 -;; -;; -;; TODO: Determine what's the right thing to do for skips. -;; Handle TABs. -;; Make line format customizable via longopts. - -;;; Code: - -(define-module (scripts read-text-outline) - :export (read-text-outline - read-text-outline-silently - make-text-outline-reader) - :use-module (ice-9 regex) - :autoload (ice-9 rdelim) (read-line) - :autoload (ice-9 getopt-long) (getopt-long)) - -(define (?? symbol) - (let ((name (symbol->string symbol))) - (string=? "?" (substring name (1- (string-length name)))))) - -(define (msub n) - (lambda (m) - (match:substring m n))) - -(define (??-predicates pair) - (cons (car pair) - (if (?? (car pair)) - (lambda (m) - (not (string=? "" (match:substring m (cdr pair))))) - (msub (cdr pair))))) - -(define (make-line-parser re specs) - (let* ((rx (let ((fc (substring re 0 1))) - (make-regexp (if (string=? "^" fc) - re - (string-append "^" re))))) - (check (lambda (key) - (assq-ref specs key))) - (level-substring (msub (or (check 'level-submatch-number) 1))) - (extract-level (cond ((check 'compute-level) - => (lambda (proc) - (lambda (m) - (proc m)))) - ((check 'level-substring-divisor) - => (lambda (n) - (lambda (m) - (/ (string-length (level-substring m)) - n)))) - (else - (lambda (m) - (string-length (level-substring m)))))) - (extract-body (cond ((check 'body-submatch-number) - => msub) - (else - (lambda (m) (match:suffix m))))) - (misc-props! (cond ((check 'extra-fields) - => (lambda (alist) - (let ((new (map ??-predicates alist))) - (lambda (obj m) - (for-each - (lambda (pair) - (set-object-property! - obj (car pair) - ((cdr pair) m))) - new))))) - (else - (lambda (obj m) #t))))) - ;; retval - (lambda (line) - (cond ((regexp-exec rx line) - => (lambda (m) - (let ((level (extract-level m)) - (body (extract-body m))) - (set-object-property! body 'level level) - (misc-props! body m) - body))) - (else #f))))) - -(define (make-text-outline-reader re specs) - (let ((parse-line (make-line-parser re specs))) - ;; retval - (lambda (port) - (let* ((all '(start)) - (pchain (list))) ; parents chain - (let loop ((line (read-line port)) - (prev-level -1) ; how this relates to the first input - ; level determines whether or not we - ; start in "sibling" or "child" mode. - ; in the end, `start' is ignored and - ; it's much easier to ignore parents - ; than siblings (sometimes). this is - ; not to encourage ignorance, however. - (tp all)) ; tail pointer - (or (eof-object? line) - (cond ((parse-line line) - => (lambda (w) - (let* ((words (list w)) - (level (object-property w 'level)) - (diff (- level prev-level))) - (cond - - ;; sibling - ((zero? diff) - ;; just extend the chain - (set-cdr! tp words)) - - ;; child - ((positive? diff) - (or (= 1 diff) - (error "unhandled diff not 1:" diff line)) - ;; parent may be contacted by uncle later (kids - ;; these days!) so save its level - (set-object-property! tp 'level prev-level) - (set! pchain (cons tp pchain)) - ;; "push down" car into hierarchy - (set-car! tp (cons (car tp) words))) - - ;; uncle - ((negative? diff) - ;; prune back to where levels match - (do ((p pchain (cdr p))) - ((= level (object-property (car p) 'level)) - (set! pchain p))) - ;; resume at this level - (set-cdr! (car pchain) words) - (set! pchain (cdr pchain)))) - - (loop (read-line port) level words)))) - (else (loop (read-line port) prev-level tp))))) - (set! all (car all)) - (if (eq? 'start all) - '() ; wasteland - (cdr all)))))) - -(define read-text-outline-silently - (make-text-outline-reader "(([ ][ ])*)- *" - '((level-substring-divisor . 2)))) - -(define (read-text-outline . args) - (write (read-text-outline-silently (open-file (car args) "r"))) - (newline) - #t) ; exit val - -(define main read-text-outline) - -;;; read-text-outline ends here diff --git a/scripts/scan-api b/scripts/scan-api deleted file mode 100755 index 29837c8a2..000000000 --- a/scripts/scan-api +++ /dev/null @@ -1,225 +0,0 @@ -#!/bin/sh -# aside from this initial boilerplate, this is actually -*- scheme -*- code -main='(module-ref (resolve-module '\''(scripts scan-api)) '\'main')' -exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" -!# -;;; scan-api --- Scan and group interpreter and libguile interface elements - -;; Copyright (C) 2002 Free Software Foundation, Inc. -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;; Boston, MA 02111-1307 USA - -;;; Author: Thien-Thi Nguyen - -;;; 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) - (stringlist grouper)) - '()) - '(Scheme C)))) - (format #t ") ;; end of meta\n") - (format #t "(interface\n") - (for-each (lambda (x) - (format #t "(~A ~A (scan-data ~S))\n" - x - (cons 'groups (get x 'groups)) - (get x 'scan-data))) - all) - (format #t ") ;; end of interface\n") - (format #t ") ;; eof\n"))) - #t) - -(define main scan-api) - -;;; scan-api ends here diff --git a/scripts/summarize-guile-TODO b/scripts/summarize-guile-TODO deleted file mode 100755 index fb659c836..000000000 --- a/scripts/summarize-guile-TODO +++ /dev/null @@ -1,214 +0,0 @@ -#!/bin/sh -# aside from this initial boilerplate, this is actually -*- scheme -*- code -main='(module-ref (resolve-module '\''(scripts summarize-guile-TODO)) '\'main')' -exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" -!# -;;; summarize-guile-TODO --- Display Guile TODO list in various ways - -;; Copyright (C) 2002 Free Software Foundation, Inc. -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 2, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;; Boston, MA 02111-1307 USA - -;;; Author: Thien-Thi Nguyen - -;;; 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