code:
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts frisk)) '\'main')'
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; frisk --- Grok the module interfaces of a body of files

;; 	Copyright (C) 2002, 2006 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., 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 *default-module* '(guile-user))

(define (grok-proc default-module note-use!)
  (lambda (filename)
    (let* ((p (open-file filename "r"))
           (next (lambda () (read p)))
           (ferret (lambda (use)   ;;; handle "((foo bar) :select ...)"
                     (let ((maybe (car use)))
                       (if (list? maybe)
                           maybe
                           use))))
           (curmod #f))
      (let loop ((form (next)))
        (cond ((eof-object? form))
              ((not (list? form)) (loop (next)))
              (else (case (car form)
                      ((define-module)
                       (let ((module (cadr form)))
                         (set! curmod module)
                         (note-use! 'def module #f)
                         (let loop ((ls form))
                           (or (null? ls)
                               (case (car ls)
                                 ((:use-module)
                                  (note-use! 'regular module (ferret (cadr ls)))
                                  (loop (cddr ls)))
                                 ((:autoload)
                                  (note-use! 'autoload module (cadr ls))
                                  (loop (cdddr ls)))
                                 (else (loop (cdr ls))))))))
                      ((use-modules)
                       (for-each (lambda (use)
                                   (note-use! 'regular
                                              (or curmod default-module)
                                              (ferret use)))
                                 (cdr form)))
                      ((load primitive-load)
                       (note-use! 'computed
                                  (or curmod default-module)
                                  (let ((file (cadr form)))
                                    (if (string? file)
                                        file
                                        (format #f "[computed in ~A]"
                                                filename))))))
                    (loop (next))))))))

(define up-ls (make-object-property))   ; list
(define dn-ls (make-object-property))   ; list
(define int?  (make-object-property))   ; defined via `define-module'

(define mod-up-ls up-ls)
(define mod-down-ls dn-ls)
(define mod-int? int?)

(define (i-or-x module)
  (if (int? module) 'i 'x))

(define edge-type (make-object-property)) ; symbol

(define (make-edge type up down)
  (let ((new (cons up down)))
    (set! (edge-type new) type)
    new))

(define edge-up car)
(define edge-down cdr)

(define (up-ls+! m new) (set! (up-ls m) (cons new (up-ls m))))
(define (dn-ls+! m new) (set! (dn-ls m) (cons new (dn-ls m))))

(define (make-body alist)
  (lambda (key)
    (assq-ref alist key)))

(define (scan default-module files)
  (let* ((modules (list))
         (edges (list))
         (intern (lambda (module)
                   (cond ((member module modules) => car)
                         (else (set! (up-ls module) (list))
                               (set! (dn-ls module) (list))
                               (set! modules (cons module modules))
                               module))))
         (grok (grok-proc default-module
                          (lambda (type d u)
                            (let ((d (intern d)))
                              (if (eq? type 'def)
                                  (set! (int? d) #t)
                                  (let* ((u (intern u))
                                         (edge (make-edge type u d)))
                                    (set! edges (cons edge edges))
                                    (up-ls+! d edge)
                                    (dn-ls+! u edge))))))))
    (for-each grok files)
    (make-body
     `((modules  . ,modules)
       (internal . ,(filter int? modules))
       (external . ,(remove int? modules))
       (i-up     . ,(filter int? (map edge-down edges)))
       (x-up     . ,(remove int? (map edge-down edges)))
       (i-down   . ,(filter int? (map edge-up   edges)))
       (x-down   . ,(remove int? (map edge-up   edges)))
       (edges    . ,edges)))))

(define (make-frisker . options)
  (let ((default-module (or (assq-ref options 'default-module)
                            *default-module*)))
    (lambda (files)
      (scan default-module files))))

(define (dump-updown modules)
  (for-each (lambda (m)
              (format #t "~A ~A --- ~A --- ~A\n"
                      (i-or-x m) m
                      (map (lambda (edge)
                             (cons (edge-type edge)
                                   (edge-up edge)))
                           (up-ls m))
                      (map (lambda (edge)
                             (cons (edge-type edge)
                                   (edge-down edge)))
                           (dn-ls m))))
            modules))

(define (dump-up modules)
  (for-each (lambda (m)
              (format #t "~A ~A\n" (i-or-x m) m)
              (for-each (lambda (edge)
                          (format #t "\t\t\t ~A\t~A\n"
                                  (edge-type edge) (edge-up edge)))
                        (up-ls m)))
            modules))

(define (dump-down modules)
  (for-each (lambda (m)
              (format #t "~A ~A\n" (i-or-x m) m)
              (for-each (lambda (edge)
                          (format #t "\t\t\t ~A\t~A\n"
                                  (edge-type edge) (edge-down edge)))
                        (dn-ls m)))
            modules))

(define (frisk . args)
  (let* ((parsed-opts (getopt-long
                       (cons "frisk" args)    ;;; kludge
                       '((upstream (single-char #\u))
                         (downstream (single-char #\d))
                         (internal (single-char #\i))
                         (external (single-char #\x))
                         (default-module
                           (single-char #\m)
                           (value #t)))))
         (=u (option-ref parsed-opts 'upstream #f))
         (=d (option-ref parsed-opts 'downstream #f))
         (=i (option-ref parsed-opts 'internal #f))
         (=x (option-ref parsed-opts 'external #f))
         (files    (option-ref parsed-opts '() (list)))
         (report   ((make-frisker
                     `(default-module
                        . ,(option-ref parsed-opts 'default-module
                                       *default-module*)))
                    files))
         (modules  (report 'modules))
         (internal (report 'internal))
         (external (report 'external))
         (edges    (report 'edges)))
    (format #t "~A ~A, ~A ~A (~A ~A, ~A ~A), ~A ~A\n\n"
            (length files)    "files"
            (length modules)  "modules"
            (length internal) "internal"
            (length external) "external"
            (length edges)    "edges")
    ((cond ((and =u =d) dump-updown)
           (=u dump-up)
           (else dump-down))
     (cond ((and =i =x) modules)
           (=i internal)
           (else external)))))

(define main frisk)

;;; frisk ends here

path: scripts/frisk


code:
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts generate-autoload)) '\'main')'
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; generate-autoload --- Display define-module form with autoload info

;; 	Copyright (C) 2001, 2006 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., 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 (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

path: scripts/generate-autoload

license: unknown


code:
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts lint)) '\'main')'
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; lint --- Preemptive checks for coding errors in Guile Scheme code

;; 	Copyright (C) 2002, 2006 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., 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.
;;
;; $ guile-tools lint `guile-tools`
;; No unresolved free variables in PROGRAM
;; No unresolved free variables in autofrisk
;; No unresolved free variables in display-commentary
;; Unresolved free variables in doc-snarf:
;; 	   doc-snarf-version
;; No unresolved free variables in frisk
;; No unresolved free variables in generate-autoload
;; No unresolved free variables in lint
;; No unresolved free variables in punify
;; No unresolved free variables in read-scheme-source
;; Unresolved free variables in snarf-check-and-output-texi:
;; 	   name
;; 	   pos
;; 	   line
;; 	   x
;; 	   rest
;; 	   ...
;; 	   do-argpos
;; 	   do-command
;; 	   do-args
;; 	   type
;; 	   num
;; 	   file
;; 	   do-arglist
;; 	   req
;; 	   opt
;; 	   var
;; 	   command
;; 	   do-directive
;; 	   s
;; 	   ?
;; No unresolved free variables in use2dot

;;; Code:

(define-module (scripts lint)
  #:use-module (ice-9 common-list)
  #:use-module (ice-9 format)
  #:export (lint))

(define (lint filename)
  (let ((module-name (scan-file-for-module-name filename))
	(free-vars (uniq (scan-file-for-free-variables filename))))
    (let ((module (resolve-module module-name))
	  (all-resolved? #t))
      (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

path: scripts/lint


code:
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts punify)) '\'main')'
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; punify --- Display Scheme code w/o unnecessary comments / whitespace

;; 	Copyright (C) 2001, 2006 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., 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 (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

path: scripts/punify


code:
#!/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, 2004, 2006 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., 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 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


code:
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts read-scheme-source)) '\'main')'
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; read-scheme-source --- Read a file, recognizing scheme forms and comments

;; 	Copyright (C) 2001, 2006 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., 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))

;; 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

path: scripts/read-scheme-source


code:
#!/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, 2006 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., 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 (?? 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

path: scripts/read-text-outline


code:
#!/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, 2006 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., 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 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

path: scripts/scan-api


code:
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main="(module-ref (resolve-module '(scripts snarf-check-and-output-texi)) 'main)"
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; snarf-check-and-output-texi --- called by the doc snarfer.

;; 	Copyright (C) 2001, 2002, 2006 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., 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))

;;; why aren't these in some module?

(define-macro (when cond . body)
  `(if ,cond (begin ,@body)))

(define-macro (unless cond . body)
  `(if (not ,cond) (begin ,@body)))

(define *manual-flag* #f)

(define (snarf-check-and-output-texi . flags)
  (if (member "--manual" flags)
      (set! *manual-flag* #t))
  (process-stream (current-input-port)))

(define (process-stream port)
  (let loop ((input (stream-map (match-lambda
                                 (('id . s)
                                  (cons 'id (string->symbol s)))
                                 (('int_dec . s)
                                  (cons 'int (string->number s)))
                                 (('int_oct . s)
                                  (cons 'int (string->number s 8)))
                                 (('int_hex . s)
                                  (cons 'int (string->number s 16)))
                                 ((and x (? symbol?))
                                  (cons x x))
                                 ((and x (? string?))
                                  (cons 'string x))
                                 (x x))
                                (make-stream (lambda (s)
                                               (let loop ((s s))
                                                 (cond
                                                   ((stream-null? s) #t)
                                                   ((eq? 'eol (stream-car s))
                                                    (loop (stream-cdr s)))
                                                   (else (cons (stream-car s) (stream-cdr s))))))
                                             (port->stream port read)))))

    (unless (stream-null? input)
      (let ((token (stream-car input)))
        (if (eq? (car token) 'snarf_cookie)
          (dispatch-top-cookie (stream-cdr input)
                               loop)
          (loop (stream-cdr input)))))))

(define (dispatch-top-cookie input cont)

  (when (stream-null? input)
    (error 'syntax "premature end of file"))

  (let ((token (stream-car input)))
    (cond
      ((eq? (car token) 'brace_open)
       (consume-multiline (stream-cdr input)
                          cont))
      (else
       (consume-upto-cookie process-singleline
                            input
                            cont)))))

(define (consume-upto-cookie process input cont)
  (let loop ((acc '()) (input input))

    (when (stream-null? input)
      (error 'syntax "premature end of file in directive context"))

    (let ((token (stream-car input)))
      (cond
        ((eq? (car token) 'snarf_cookie)
         (process (reverse! acc))
         (cont (stream-cdr input)))

        (else (loop (cons token acc) (stream-cdr input)))))))

(define (consume-multiline input cont)
  (begin-multiline)

  (let loop ((input input))

    (when (stream-null? input)
      (error 'syntax "premature end of file in multiline context"))

    (let ((token (stream-car input)))
      (cond
        ((eq? (car token) 'brace_close)
         (end-multiline)
         (cont (stream-cdr input)))

        (else (consume-upto-cookie process-multiline-directive
                                   input
                                   loop))))))

(define *file* #f)
(define *line* #f)
(define *c-function-name* #f)
(define *function-name* #f)
(define *snarf-type* #f)
(define *args* #f)
(define *sig* #f)
(define *docstring* #f)

(define (begin-multiline)
  (set! *file* #f)
  (set! *line* #f)
  (set! *c-function-name* #f)
  (set! *function-name* #f)
  (set! *snarf-type* #f)
  (set! *args* #f)
  (set! *sig* #f)
  (set! *docstring* #f))

(define *primitive-deffnx-signature* "@deffnx {Scheme Procedure} ")
(define *primitive-deffnx-sig-length* (string-length *primitive-deffnx-signature*))

(define (end-multiline)
  (let* ((req (car *sig*))
         (opt (cadr *sig*))
         (var (caddr *sig*))
         (all (+ req opt var)))
    (if (and (not (eqv? *snarf-type* 'register))
             (not (= (length *args*) all)))
      (error (format #f "~A:~A: ~A's C implementation takes ~A args (should take ~A)"
             *file* *line* *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))

     ;; newer gccs like to throw around more location markers into the
     ;; preprocessed source; these (hash . hash) bits are what they translate to
     ;; in snarfy terms.
     (('location ('string . file) ('int . line) ('hash . 'hash))
      (set! *file* file)
      (set! *line* line))

     (('location ('hash . 'hash) ('string . file) ('int . line) ('hash . 'hash))
      (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)

path: scripts/snarf-check-and-output-texi


code:
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts snarf-guile-m4-docs)) '\'main')'
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; snarf-guile-m4-docs --- Parse guile.m4 comments for texi documentation

;; 	Copyright (C) 2002, 2006 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., 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 (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


code:
#!/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, 2006 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., 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 '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 (srfi srfi-14) (char-set) ; 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 (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

path: scripts/summarize-guile-TODO


code:
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts use2dot)) '\'main')'
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; use2dot --- Display module dependencies as a DOT specification

;; 	Copyright (C) 2001, 2006 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., 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 *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