mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-03 21:30:29 +02:00
Fix the mess I made.
This commit is contained in:
Rob Browning
parent
440333c865
commit
4304846e08
16 changed files with 3032 additions and 0 deletions
286
scripts/ChangeLog
Normal file
286
scripts/ChangeLog
Normal file
|
|
@ -0,0 +1,286 @@
|
||||||
|
2002-05-18 Thien-Thi Nguyen <ttn@giblet.glug.org>
|
||||||
|
|
||||||
|
* api-diff (group-diff): Also output +N and -N adds and subs
|
||||||
|
details, respectively.
|
||||||
|
|
||||||
|
2002-05-13 Thien-Thi Nguyen <ttn@giblet.glug.org>
|
||||||
|
|
||||||
|
* read-rfc822: New script.
|
||||||
|
|
||||||
|
* Makefile.am (scripts_sources): Add api-diff and read-rfc822.
|
||||||
|
|
||||||
|
* scan-api (scan-api): No longer include timestamp.
|
||||||
|
|
||||||
|
2002-05-11 Thien-Thi Nguyen <ttn@giblet.glug.org>
|
||||||
|
|
||||||
|
* scan-api (scan-api): Fix bug: No longer omit `C' and `Scheme' in
|
||||||
|
groups in the presence of the grouper.
|
||||||
|
|
||||||
|
* api-diff: Use modules (ice-9 format), (ice-9 getopt-long).
|
||||||
|
Autoload module (srfi srfi-13).
|
||||||
|
No longer export `diff-alists'.
|
||||||
|
|
||||||
|
(diff, diff-alists, display-list): Remove.
|
||||||
|
(put, get, read-api-alist-file, hang-by-the-roots, diff?,
|
||||||
|
diff+note!, group-diff): New procs.
|
||||||
|
(api-diff): Rewrite.
|
||||||
|
|
||||||
|
2002-05-10 Thien-Thi Nguyen <ttn@giblet.glug.org>
|
||||||
|
|
||||||
|
* scan-api (add-props): New proc.
|
||||||
|
(make-grok-proc): Renamed from `make-grok-hook'.
|
||||||
|
(make-members-proc): Renamed from `make-members-hook'.
|
||||||
|
(make-grouper): Renamed from `make-grouping-hook'. Update callers.
|
||||||
|
Add handling for multiple grouping-defs files.
|
||||||
|
(scan-api): Add handling for multiple grouping-defs files.
|
||||||
|
Cache `symbol->string' result; adjust `sort' usage.
|
||||||
|
|
||||||
|
2002-05-09 Thien-Thi Nguyen <ttn@giblet.glug.org>
|
||||||
|
|
||||||
|
* scan-api (scan-C!): Use more robust regexp.
|
||||||
|
|
||||||
|
2002-05-08 Thien-Thi Nguyen <ttn@giblet.glug.org>
|
||||||
|
|
||||||
|
* scan-api: New script.
|
||||||
|
(scan-api): Handle case where `grouping-hook' is #f.
|
||||||
|
|
||||||
|
Remove top-level `debug-enable' form.
|
||||||
|
Add TODO comment; nfc.
|
||||||
|
|
||||||
|
* Makefile.am (scripts_sources): Add "scan-api".
|
||||||
|
|
||||||
|
2002-04-30 Thien-Thi Nguyen <ttn@giblet.glug.org>
|
||||||
|
|
||||||
|
* summarize-guile-TODO (make-display-item):
|
||||||
|
Hoist some lambdas; nfc.
|
||||||
|
|
||||||
|
2002-04-29 Thien-Thi Nguyen <ttn@giblet.glug.org>
|
||||||
|
|
||||||
|
* summarize-guile-TODO: Fix commentary typo; nfc.
|
||||||
|
|
||||||
|
2002-04-08 Thien-Thi Nguyen <ttn@giblet.glug.org>
|
||||||
|
|
||||||
|
* summarize-guile-TODO: Use (ice-9 getopt-long).
|
||||||
|
Autoload (ice-9 common-list).
|
||||||
|
|
||||||
|
(select-items): New proc.
|
||||||
|
(make-display-item): New proc.
|
||||||
|
(display-item): Delete.
|
||||||
|
(display-items): Use `make-display-item'.
|
||||||
|
(summarize-guile-TODO): Add option handling.
|
||||||
|
|
||||||
|
2002-04-07 Thien-Thi Nguyen <ttn@giblet.glug.org>
|
||||||
|
|
||||||
|
* summarize-guile-TODO: Add "Bugs" section to commentary.
|
||||||
|
Autoload (srfi srfi-13) on `string-tokenize'.
|
||||||
|
|
||||||
|
(as-leaf): New proc.
|
||||||
|
(hang-by-the-leaves): Use `as-leaf'.
|
||||||
|
(read-TODO-file): Expand regexp and specs
|
||||||
|
to handle "D", "X" and "N%". Fix regexp
|
||||||
|
to make isolating `who' easier.
|
||||||
|
(display-item): Handle "D", "X" and "N%".
|
||||||
|
|
||||||
|
2002-04-06 Thien-Thi Nguyen <ttn@giblet.glug.org>
|
||||||
|
|
||||||
|
* summarize-guile-TODO: New script.
|
||||||
|
|
||||||
|
* Makefile.am (scripts_sources): Add "summarize-guile-TODO".
|
||||||
|
|
||||||
|
2002-04-05 Thien-Thi Nguyen <ttn@giblet.glug.org>
|
||||||
|
|
||||||
|
* read-text-outline (display-outline-tree): No longer export this proc.
|
||||||
|
|
||||||
|
(*depth-cue-rx*, *subm-number*, *level-divisor*, >>,
|
||||||
|
display-outline-tree): Delete these vars and procs.
|
||||||
|
|
||||||
|
(??, msub, ??-predicates, make-line-parser,
|
||||||
|
make-text-outline-reader): New procs.
|
||||||
|
|
||||||
|
(make-text-outline-reader): Export.
|
||||||
|
(read-text-outline-silently): Rewrite
|
||||||
|
using `make-text-outline-reader'.
|
||||||
|
|
||||||
|
2002-04-04 Thien-Thi Nguyen <ttn@giblet.glug.org>
|
||||||
|
|
||||||
|
* lint: New script.
|
||||||
|
|
||||||
|
* Makefile.am (scripts_sources): Add "lint".
|
||||||
|
|
||||||
|
2002-04-02 Thien-Thi Nguyen <ttn@giblet.glug.org>
|
||||||
|
|
||||||
|
* PROGRAM: Update copyright; nfc.
|
||||||
|
|
||||||
|
* read-text-outline: New script.
|
||||||
|
|
||||||
|
* Makefile.am (scripts_sources): Add "read-text-outline".
|
||||||
|
|
||||||
|
* read-text-outline (read-text-outline-silently):
|
||||||
|
Move `tp' inside `loop'; nfc.
|
||||||
|
|
||||||
|
2002-03-12 Neil Jerram <neil@ossau.uklinux.net>
|
||||||
|
|
||||||
|
* snarf-check-and-output-texi (snarf-check-and-output-texi): If
|
||||||
|
supplied, the `--manual' flag arrives as a string, not a symbol,
|
||||||
|
so test for it as such.
|
||||||
|
|
||||||
|
2002-03-03 Neil Jerram <neil@ossau.uklinux.net>
|
||||||
|
|
||||||
|
* snarf-guile-m4-docs (display-texi): Strip off `# ' from start of
|
||||||
|
docstring lines if possible, rather than just `#'.
|
||||||
|
|
||||||
|
2002-02-26 Thien-Thi Nguyen <ttn@giblet.glug.org>
|
||||||
|
|
||||||
|
* Makefile.am: Update path to pre-inst-guile automake frag.
|
||||||
|
|
||||||
|
2002-02-22 Thien-Thi Nguyen <ttn@giblet.glug.org>
|
||||||
|
|
||||||
|
* api-diff: New script.
|
||||||
|
|
||||||
|
2002-02-05 Thien-Thi Nguyen <ttn@giblet.glug.org>
|
||||||
|
|
||||||
|
* Include $(top_srcdir)/pre-inst-guile.am.
|
||||||
|
|
||||||
|
(overview): Use $(preinstguiletool).
|
||||||
|
|
||||||
|
2002-01-11 Thien-Thi Nguyen <ttn@giblet.glug.org>
|
||||||
|
|
||||||
|
* Makefile.am (scripts_sources): Add autofrisk.
|
||||||
|
|
||||||
|
* autofrisk: New script.
|
||||||
|
|
||||||
|
* frisk: Fix typo in commentary; nfc.
|
||||||
|
|
||||||
|
* use2dot: Autoload module (ice-9 getopt-long).
|
||||||
|
Use module (srfi srfi-13).
|
||||||
|
Export `use2dot'.
|
||||||
|
|
||||||
|
(string-append/separator, mapconcat): Delete.
|
||||||
|
(vv): Now take list of pairs, and return the mapping..
|
||||||
|
(>>header): Use `string-join'.
|
||||||
|
(>>): New proc.
|
||||||
|
(use2dot): Use `getopt-long'. Use `>>'.
|
||||||
|
|
||||||
|
2002-01-08 Thien-Thi Nguyen <ttn@giblet.glug.org>
|
||||||
|
|
||||||
|
* Makefile.am (scripts_sources): Add frisk.
|
||||||
|
(list): New target.
|
||||||
|
(overview): Also report module interfaces.
|
||||||
|
|
||||||
|
* use2dot: Rewrite using (scripts frisk).
|
||||||
|
|
||||||
|
* frisk: Initial revision.
|
||||||
|
|
||||||
|
2002-01-02 Thien-Thi Nguyen <ttn@giblet.glug.org>
|
||||||
|
|
||||||
|
* snarf-guile-m4-docs: New script.
|
||||||
|
|
||||||
|
2001-11-28 Thien-Thi Nguyen <ttn@giblet.glug.org>
|
||||||
|
|
||||||
|
* punify (write-punily): Handle symbols w/ ":" prefix specially.
|
||||||
|
|
||||||
|
* use2dot (ferret): New proc.
|
||||||
|
(grok): Use `ferret'.
|
||||||
|
|
||||||
|
2001-11-16 Neil Jerram <neil@ossau.uklinux.net>
|
||||||
|
|
||||||
|
* snarf-check-and-output-texi: Change generated @deffn categories
|
||||||
|
from "function" and "primitive" to "C Function" and "Scheme
|
||||||
|
Procedure".
|
||||||
|
(end-multiline): Take out @findex generation again; not needed
|
||||||
|
since index entries are implicit in @deffn forms.
|
||||||
|
|
||||||
|
These changes add a @deffnx C function declaration and function
|
||||||
|
index entries for each Guile primitive to the copy of the doc
|
||||||
|
snarf output that is used for reference manual synchronization.
|
||||||
|
Online help is unchanged.
|
||||||
|
|
||||||
|
* snarf-check-and-output-texi (*manual-flag*,
|
||||||
|
snarf-check-and-output-texi): Handle `--manual' invocation arg
|
||||||
|
passed through from libguile/Makefile.am.
|
||||||
|
(*c-function-name*, begin-multiline, do-command): Pick out C
|
||||||
|
function name from snarfed token stream.
|
||||||
|
(end-multiline): Add @deffnx C declaration and function index
|
||||||
|
entries to output.
|
||||||
|
(*primitive-deffnx-signature*, *primitive-deffnx-sig-length*):
|
||||||
|
Fluff to help insert the C declaration after any "@deffnx
|
||||||
|
primitive" lines in the snarfed docstring.
|
||||||
|
|
||||||
|
2001-10-05 Thien-Thi Nguyen <ttn@glug.org>
|
||||||
|
|
||||||
|
* read-scheme-source (quoted?, clump): New procs, exported.
|
||||||
|
|
||||||
|
2001-09-30 Thien-Thi Nguyen <ttn@glug.org>
|
||||||
|
|
||||||
|
* display-commentary (module-name->filename-frag,
|
||||||
|
display-module-commentary): New procs.
|
||||||
|
(display-commentary): Also handle refs that look like module
|
||||||
|
names.
|
||||||
|
|
||||||
|
2001-08-25 Marius Vollmer <mvo@zagadka.ping.de>
|
||||||
|
|
||||||
|
* Makefile.am (AUTOMAKE_OPTIONS): Change "foreign" to "gnu".
|
||||||
|
|
||||||
|
2001-08-07 Michael Livshin <mlivshin@bigfoot.com>
|
||||||
|
|
||||||
|
* snarf-check-and-output-texi: print optional args in a prettier
|
||||||
|
manner.
|
||||||
|
|
||||||
|
2001-08-01 Thien-Thi Nguyen <ttn@revel.glug.org>
|
||||||
|
|
||||||
|
* PROGRAM, README, display-commentary, doc-snarf,
|
||||||
|
generate-autoload, punify, read-scheme-source,
|
||||||
|
snarf-check-and-output-texi, use2dot:
|
||||||
|
In boilerplate, use -l$0.
|
||||||
|
Thanks to Daniel Skarda.
|
||||||
|
|
||||||
|
2001-07-22 Thien-Thi Nguyen <ttn@revel.glug.org>
|
||||||
|
|
||||||
|
* generate-autoload (autoload-info):
|
||||||
|
Also handle `defmacro-public' forms.
|
||||||
|
|
||||||
|
2001-07-14 Thien-Thi Nguyen <ttn@revel.glug.org>
|
||||||
|
|
||||||
|
* PROGRAM, display-commentary, doc-snarf, generate-autoload,
|
||||||
|
punify, read-scheme-source, snarf-check-and-output-texi, use2dot:
|
||||||
|
Re-add authorship info.
|
||||||
|
|
||||||
|
2001-07-12 Michael Livshin <mlivshin@bigfoot.com>
|
||||||
|
|
||||||
|
* snarf-check-and-output-texi (do-argpos): complain to the stderr,
|
||||||
|
not stdout. thanks to Dale P. Smith!
|
||||||
|
(nice-sig): cosmetic fix.
|
||||||
|
|
||||||
|
2001-07-09 Thien-Thi Nguyen <ttn@revel.glug.org>
|
||||||
|
|
||||||
|
* PROGRAM, generate-autoload, use2dot, punify, display-commentary,
|
||||||
|
doc-snarf, read-scheme-source, snarf-check-and-output-texi:
|
||||||
|
Remove authorship info.
|
||||||
|
|
||||||
|
2001-06-25 Michael Livshin <mlivshin@bigfoot.com>
|
||||||
|
|
||||||
|
* snarf-check-and-output-texi: rewrite.
|
||||||
|
|
||||||
|
2001-05-31 Michael Livshin <mlivshin@bigfoot.com>
|
||||||
|
|
||||||
|
* snarf-check-and-output-texi: new file.
|
||||||
|
|
||||||
|
* Makefile.am (scripts_sources): add snarf-check-and-output-texi.
|
||||||
|
|
||||||
|
2001-05-14 Thien-Thi Nguyen <ttn@revel.glug.org>
|
||||||
|
|
||||||
|
* PROGRAM, display-commentary, doc-snarf, generate-autoload,
|
||||||
|
punify, read-scheme-source, use2dot: Move author tag outside
|
||||||
|
commentary; nfc.
|
||||||
|
|
||||||
|
2001-05-08 Thien-Thi Nguyen <ttn@revel.glug.org>
|
||||||
|
|
||||||
|
* read-scheme-source: New file
|
||||||
|
|
||||||
|
* Makefile.am (scripts_sources): Add read-scheme-source.
|
||||||
|
|
||||||
|
2001-04-29 Thien-Thi Nguyen <ttn@revel.glug.org>
|
||||||
|
|
||||||
|
* Makefile.am, PROGRAM, README, display-commentary,
|
||||||
|
doc-snarf, generate-autoload, punify, use2dot: New file
|
||||||
|
|
||||||
67
scripts/Makefile.am
Normal file
67
scripts/Makefile.am
Normal file
|
|
@ -0,0 +1,67 @@
|
||||||
|
## Process this file with automake to produce Makefile.in.
|
||||||
|
##
|
||||||
|
## Copyright (C) 2002 Free Software Foundation, Inc.
|
||||||
|
##
|
||||||
|
## This file is part of GUILE.
|
||||||
|
##
|
||||||
|
## GUILE is free software; you can redistribute it and/or modify
|
||||||
|
## it under the terms of the GNU General Public License as
|
||||||
|
## published by the Free Software Foundation; either version 2, or
|
||||||
|
## (at your option) any later version.
|
||||||
|
##
|
||||||
|
## GUILE is distributed in the hope that it will be useful, but
|
||||||
|
## WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||||
|
## GNU General Public License for more details.
|
||||||
|
##
|
||||||
|
## You should have received a copy of the GNU General Public
|
||||||
|
## License along with GUILE; see the file COPYING. If not, write
|
||||||
|
## to the Free Software Foundation, Inc., 59 Temple Place, Suite
|
||||||
|
## 330, Boston, MA 02111-1307 USA
|
||||||
|
|
||||||
|
AUTOMAKE_OPTIONS = gnu
|
||||||
|
|
||||||
|
# These should be installed and distributed.
|
||||||
|
scripts_sources = \
|
||||||
|
PROGRAM \
|
||||||
|
autofrisk \
|
||||||
|
display-commentary \
|
||||||
|
doc-snarf \
|
||||||
|
frisk \
|
||||||
|
generate-autoload \
|
||||||
|
lint \
|
||||||
|
punify \
|
||||||
|
read-scheme-source \
|
||||||
|
read-text-outline \
|
||||||
|
use2dot \
|
||||||
|
snarf-check-and-output-texi \
|
||||||
|
summarize-guile-TODO \
|
||||||
|
scan-api \
|
||||||
|
api-diff \
|
||||||
|
read-rfc822
|
||||||
|
|
||||||
|
subpkgdatadir = $(pkgdatadir)/$(VERSION)/scripts
|
||||||
|
subpkgdata_SCRIPTS = $(scripts_sources)
|
||||||
|
|
||||||
|
EXTRA_DIST = $(scripts_sources)
|
||||||
|
|
||||||
|
list:
|
||||||
|
@echo $(scripts_sources)
|
||||||
|
|
||||||
|
include $(top_srcdir)/am/pre-inst-guile
|
||||||
|
|
||||||
|
overview: $(scripts_sources)
|
||||||
|
@echo '----------------------------'
|
||||||
|
@echo Overview
|
||||||
|
@echo I. Commentaries
|
||||||
|
@echo II. Module Interfaces
|
||||||
|
@echo '----------------------------'
|
||||||
|
@echo I. Commentaries
|
||||||
|
@echo '----------------------------'
|
||||||
|
$(preinstguiletool)/display-commentary $^
|
||||||
|
@echo '----------------------------'
|
||||||
|
@echo II. Module Interfaces
|
||||||
|
@echo '----------------------------'
|
||||||
|
$(preinstguiletool)/frisk $^
|
||||||
|
|
||||||
|
# Makefile.am ends here
|
||||||
45
scripts/PROGRAM
Executable file
45
scripts/PROGRAM
Executable file
|
|
@ -0,0 +1,45 @@
|
||||||
|
#!/bin/sh
|
||||||
|
# aside from this initial boilerplate, this is actually -*- scheme -*- code
|
||||||
|
main='(module-ref (resolve-module '\''(scripts PROGRAM)) '\'main')'
|
||||||
|
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
|
||||||
|
!#
|
||||||
|
;;; PROGRAM --- Does something
|
||||||
|
|
||||||
|
;; Copyright (C) 2002 Free Software Foundation, Inc.
|
||||||
|
;;
|
||||||
|
;; This program is free software; you can redistribute it and/or
|
||||||
|
;; modify it under the terms of the GNU General Public License as
|
||||||
|
;; published by the Free Software Foundation; either version 2, or
|
||||||
|
;; (at your option) any later version.
|
||||||
|
;;
|
||||||
|
;; This program is distributed in the hope that it will be useful,
|
||||||
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||||
|
;; General Public License for more details.
|
||||||
|
;;
|
||||||
|
;; You should have received a copy of the GNU General Public License
|
||||||
|
;; along with this software; see the file COPYING. If not, write to
|
||||||
|
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||||
|
;; Boston, MA 02111-1307 USA
|
||||||
|
|
||||||
|
;;; Author: J.R.Hacker
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;; Usage: PROGRAM [ARGS]
|
||||||
|
;;
|
||||||
|
;; PROGRAM does something.
|
||||||
|
;;
|
||||||
|
;; TODO: Write it!
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(define-module (scripts PROGRAM)
|
||||||
|
:export (PROGRAM))
|
||||||
|
|
||||||
|
(define (PROGRAM . args)
|
||||||
|
#t)
|
||||||
|
|
||||||
|
(define main PROGRAM)
|
||||||
|
|
||||||
|
;;; PROGRAM ends here
|
||||||
76
scripts/README
Normal file
76
scripts/README
Normal file
|
|
@ -0,0 +1,76 @@
|
||||||
|
Overview and Usage
|
||||||
|
------------------
|
||||||
|
|
||||||
|
This directory contains Scheme programs, some useful in maintaining Guile.
|
||||||
|
On "make install", these programs are copied to PKGDATADIR/VERSION/scripts.
|
||||||
|
|
||||||
|
You can invoke a program from the shell, or alternatively, load its file
|
||||||
|
as a Guile Scheme module, and use its exported procedure(s) from Scheme code.
|
||||||
|
Typically for any PROGRAM:
|
||||||
|
|
||||||
|
(use-modules (scripts PROGRAM))
|
||||||
|
(PROGRAM ARG1 ARG2 ...)
|
||||||
|
|
||||||
|
For programs that write to stdout, you might try, instead:
|
||||||
|
|
||||||
|
(use-modules (scripts PROGRAM))
|
||||||
|
(with-output-to-string (lambda () (PROGRAM ARG1 ARG2 ...)))
|
||||||
|
|
||||||
|
Note that all args must be strings.
|
||||||
|
|
||||||
|
To see PROGRAM's commentary, which may or may not be helpful:
|
||||||
|
|
||||||
|
(help (scripts PROGRAM))
|
||||||
|
|
||||||
|
To see all commentaries and module dependencies, try: "make overview".
|
||||||
|
|
||||||
|
If you want to try the programs before installing Guile, you will probably
|
||||||
|
need to set environment variable GUILE_LOAD_PATH to be the parent directory.
|
||||||
|
This can be done in Bourne-compatible shells like so:
|
||||||
|
|
||||||
|
GUILE_LOAD_PATH=`(cd .. ; pwd)`
|
||||||
|
export GUILE_LOAD_PATH
|
||||||
|
|
||||||
|
[FIXME: Can someone supply the csh-compatible equivalent?]
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
How to Contribute
|
||||||
|
-----------------
|
||||||
|
|
||||||
|
See template file PROGRAM for a quick start.
|
||||||
|
|
||||||
|
Programs must follow the "executable module" convention, documented here:
|
||||||
|
|
||||||
|
- The file name must not end in ".scm".
|
||||||
|
|
||||||
|
- The file must be executable (chmod +x).
|
||||||
|
|
||||||
|
- The module name must be "(scripts PROGRAM)". A procedure named PROGRAM w/
|
||||||
|
signature "(PROGRAM . args)" must be exported. Basically, use some variant
|
||||||
|
of the form:
|
||||||
|
|
||||||
|
(define-module (scripts PROGRAM)
|
||||||
|
:export (PROGRAM))
|
||||||
|
|
||||||
|
Feel free to export other definitions useful in the module context.
|
||||||
|
|
||||||
|
- There must be the alias:
|
||||||
|
|
||||||
|
(define main PROGRAM)
|
||||||
|
|
||||||
|
However, `main' must NOT be exported.
|
||||||
|
|
||||||
|
- The beginning of the file must use the following invocation sequence:
|
||||||
|
|
||||||
|
#!/bin/sh
|
||||||
|
main='(module-ref (resolve-module '\''(scripts PROGRAM)) '\'main')'
|
||||||
|
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
|
||||||
|
!#
|
||||||
|
|
||||||
|
Following these conventions allows the program file to be used as module
|
||||||
|
(scripts PROGRAM) in addition to as a standalone executable. Please also
|
||||||
|
include a helpful Commentary section w/ some usage info.
|
||||||
|
|
||||||
|
|
||||||
|
[README ends here]
|
||||||
181
scripts/api-diff
Executable file
181
scripts/api-diff
Executable file
|
|
@ -0,0 +1,181 @@
|
||||||
|
#!/bin/sh
|
||||||
|
# aside from this initial boilerplate, this is actually -*- scheme -*- code
|
||||||
|
main='(module-ref (resolve-module '\''(scripts api-diff)) '\'main')'
|
||||||
|
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
|
||||||
|
!#
|
||||||
|
;;; api-diff --- diff guile-api.alist files
|
||||||
|
|
||||||
|
;; Copyright (C) 2002 Free Software Foundation, Inc.
|
||||||
|
;;
|
||||||
|
;; This program is free software; you can redistribute it and/or
|
||||||
|
;; modify it under the terms of the GNU General Public License as
|
||||||
|
;; published by the Free Software Foundation; either version 2, or
|
||||||
|
;; (at your option) any later version.
|
||||||
|
;;
|
||||||
|
;; This program is distributed in the hope that it will be useful,
|
||||||
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||||
|
;; General Public License for more details.
|
||||||
|
;;
|
||||||
|
;; You should have received a copy of the GNU General Public License
|
||||||
|
;; along with this software; see the file COPYING. If not, write to
|
||||||
|
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||||
|
;; Boston, MA 02111-1307 USA
|
||||||
|
|
||||||
|
;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;; Usage: api-diff [-d GROUPS] ALIST-FILE-A ALIST-FILE-B
|
||||||
|
;;
|
||||||
|
;; Read in the alists from files ALIST-FILE-A and ALIST-FILE-B
|
||||||
|
;; and display a (count) summary of the groups defined therein.
|
||||||
|
;; Optional arg "--details" (or "-d") specifies a comma-separated
|
||||||
|
;; list of groups, in which case api-diff displays instead the
|
||||||
|
;; elements added and deleted for each of the specified groups.
|
||||||
|
;;
|
||||||
|
;; For scheme programming, this module exports the proc:
|
||||||
|
;; (api-diff A-file B-file)
|
||||||
|
;;
|
||||||
|
;; Note that the convention is that the "older" alist/file is
|
||||||
|
;; specified first.
|
||||||
|
;;
|
||||||
|
;; TODO: Develop scheme interface.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(define-module (scripts api-diff)
|
||||||
|
:use-module (ice-9 common-list)
|
||||||
|
:use-module (ice-9 format)
|
||||||
|
:use-module (ice-9 getopt-long)
|
||||||
|
:autoload (srfi srfi-13) (string-tokenize)
|
||||||
|
:export (api-diff))
|
||||||
|
|
||||||
|
(define (read-alist-file file)
|
||||||
|
(with-input-from-file file
|
||||||
|
(lambda () (read))))
|
||||||
|
|
||||||
|
(define put set-object-property!)
|
||||||
|
(define get object-property)
|
||||||
|
|
||||||
|
(define (read-api-alist-file file)
|
||||||
|
(let* ((alist (read-alist-file file))
|
||||||
|
(meta (assq-ref alist 'meta))
|
||||||
|
(interface (assq-ref alist 'interface)))
|
||||||
|
(put interface 'meta meta)
|
||||||
|
(put interface 'groups (let ((ht (make-hash-table 31)))
|
||||||
|
(for-each (lambda (group)
|
||||||
|
(hashq-set! ht group '()))
|
||||||
|
(assq-ref meta 'groups))
|
||||||
|
ht))
|
||||||
|
interface))
|
||||||
|
|
||||||
|
(define (hang-by-the-roots interface)
|
||||||
|
(let ((ht (get interface 'groups)))
|
||||||
|
(for-each (lambda (x)
|
||||||
|
(for-each (lambda (group)
|
||||||
|
(hashq-set! ht group
|
||||||
|
(cons (car x)
|
||||||
|
(hashq-ref ht group))))
|
||||||
|
(assq-ref x 'groups)))
|
||||||
|
interface))
|
||||||
|
interface)
|
||||||
|
|
||||||
|
(define (diff? a b)
|
||||||
|
(let ((result (set-difference a b)))
|
||||||
|
(if (null? result)
|
||||||
|
#f ; CL weenies bite me
|
||||||
|
result)))
|
||||||
|
|
||||||
|
(define (diff+note! a b note-removals note-additions note-same)
|
||||||
|
(let ((same? #t))
|
||||||
|
(cond ((diff? a b) => (lambda (x) (note-removals x) (set! same? #f))))
|
||||||
|
(cond ((diff? b a) => (lambda (x) (note-additions x) (set! same? #f))))
|
||||||
|
(and same? (note-same))))
|
||||||
|
|
||||||
|
(define (group-diff i-old i-new . options)
|
||||||
|
(let* ((i-old (hang-by-the-roots i-old))
|
||||||
|
(g-old (hash-fold acons '() (get i-old 'groups)))
|
||||||
|
(g-old-names (map car g-old))
|
||||||
|
(i-new (hang-by-the-roots i-new))
|
||||||
|
(g-new (hash-fold acons '() (get i-new 'groups)))
|
||||||
|
(g-new-names (map car g-new)))
|
||||||
|
(cond ((null? options)
|
||||||
|
(diff+note! g-old-names g-new-names
|
||||||
|
(lambda (removals)
|
||||||
|
(format #t "groups-removed: ~A\n" removals))
|
||||||
|
(lambda (additions)
|
||||||
|
(format #t "groups-added: ~A\n" additions))
|
||||||
|
(lambda () #t))
|
||||||
|
(for-each (lambda (group)
|
||||||
|
(let* ((old (assq-ref g-old group))
|
||||||
|
(new (assq-ref g-new group))
|
||||||
|
(old-count (and old (length old)))
|
||||||
|
(new-count (and new (length new)))
|
||||||
|
(delta (and old new (- new-count old-count))))
|
||||||
|
(format #t " ~5@A ~5@A : "
|
||||||
|
(or old-count "-")
|
||||||
|
(or new-count "-"))
|
||||||
|
(cond ((and old new)
|
||||||
|
(let ((add-count 0) (sub-count 0))
|
||||||
|
(diff+note!
|
||||||
|
old new
|
||||||
|
(lambda (subs)
|
||||||
|
(set! sub-count (length subs)))
|
||||||
|
(lambda (adds)
|
||||||
|
(set! add-count (length adds)))
|
||||||
|
(lambda () #t))
|
||||||
|
(format #t "~5@D ~5@D : ~5@D"
|
||||||
|
add-count (- sub-count) delta)))
|
||||||
|
(else
|
||||||
|
(format #t "~5@A ~5@A : ~5@A" "-" "-" "-")))
|
||||||
|
(format #t " ~A\n" group)))
|
||||||
|
(sort (union g-old-names g-new-names)
|
||||||
|
(lambda (a b)
|
||||||
|
(string<? (symbol->string a)
|
||||||
|
(symbol->string b))))))
|
||||||
|
((assq-ref options 'details)
|
||||||
|
=> (lambda (groups)
|
||||||
|
(for-each (lambda (group)
|
||||||
|
(let* ((old (or (assq-ref g-old group) '()))
|
||||||
|
(new (or (assq-ref g-new group) '()))
|
||||||
|
(>>! (lambda (label ls)
|
||||||
|
(format #t "~A ~A:\n" group label)
|
||||||
|
(for-each (lambda (x)
|
||||||
|
(format #t " ~A\n" x))
|
||||||
|
ls))))
|
||||||
|
(diff+note! old new
|
||||||
|
(lambda (removals)
|
||||||
|
(>>! 'removals removals))
|
||||||
|
(lambda (additions)
|
||||||
|
(>>! 'additions additions))
|
||||||
|
(lambda ()
|
||||||
|
(format #t "~A: no changes\n"
|
||||||
|
group)))))
|
||||||
|
groups)))
|
||||||
|
(else
|
||||||
|
(error "api-diff: group-diff: bad options")))))
|
||||||
|
|
||||||
|
(define (api-diff . args)
|
||||||
|
(let* ((p (getopt-long (cons 'api-diff args)
|
||||||
|
'((details (single-char #\d)
|
||||||
|
(value #t))
|
||||||
|
;; Add options here.
|
||||||
|
)))
|
||||||
|
(rest (option-ref p '() '("/dev/null" "/dev/null")))
|
||||||
|
(i-old (read-api-alist-file (car rest)))
|
||||||
|
(i-new (read-api-alist-file (cadr rest)))
|
||||||
|
(options '()))
|
||||||
|
(cond ((option-ref p 'details #f)
|
||||||
|
=> (lambda (groups)
|
||||||
|
(set! options (cons (cons 'details
|
||||||
|
(map string->symbol
|
||||||
|
(string-tokenize
|
||||||
|
groups
|
||||||
|
#\,)))
|
||||||
|
options)))))
|
||||||
|
(apply group-diff i-old i-new options)))
|
||||||
|
|
||||||
|
(define main api-diff)
|
||||||
|
|
||||||
|
;;; api-diff ends here
|
||||||
221
scripts/autofrisk
Executable file
221
scripts/autofrisk
Executable file
|
|
@ -0,0 +1,221 @@
|
||||||
|
#!/bin/sh
|
||||||
|
# aside from this initial boilerplate, this is actually -*- scheme -*- code
|
||||||
|
main='(module-ref (resolve-module '\''(scripts autofrisk)) '\'main')'
|
||||||
|
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
|
||||||
|
!#
|
||||||
|
;;; autofrisk --- Generate module checks for use with auto* tools
|
||||||
|
|
||||||
|
;; Copyright (C) 2002 Free Software Foundation, Inc.
|
||||||
|
;;
|
||||||
|
;; This program is free software; you can redistribute it and/or
|
||||||
|
;; modify it under the terms of the GNU General Public License as
|
||||||
|
;; published by the Free Software Foundation; either version 2, or
|
||||||
|
;; (at your option) any later version.
|
||||||
|
;;
|
||||||
|
;; This program is distributed in the hope that it will be useful,
|
||||||
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||||
|
;; General Public License for more details.
|
||||||
|
;;
|
||||||
|
;; You should have received a copy of the GNU General Public License
|
||||||
|
;; along with this software; see the file COPYING. If not, write to
|
||||||
|
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||||
|
;; Boston, MA 02111-1307 USA
|
||||||
|
|
||||||
|
;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;; Usage: autofrisk [file]
|
||||||
|
;;
|
||||||
|
;; This program looks for the file modules.af in the current directory
|
||||||
|
;; and writes out modules.af.m4 containing autoconf definitions.
|
||||||
|
;; If given, look for FILE instead of modules.af and output to FILE.m4.
|
||||||
|
;;
|
||||||
|
;; After running autofrisk, you should add to configure.ac the lines:
|
||||||
|
;; AUTOFRISK_CHECKS
|
||||||
|
;; AUTOFRISK_SUMMARY
|
||||||
|
;; Then run "aclocal -I ." to update aclocal.m4, and finally autoconf.
|
||||||
|
;;
|
||||||
|
;; The modules.af file consists of a series of configuration forms (Scheme
|
||||||
|
;; lists), which have one of the following formats:
|
||||||
|
;; (files-glob PATTERN ...)
|
||||||
|
;; (non-critical-external MODULE ...)
|
||||||
|
;; (non-critical-internal MODULE ...)
|
||||||
|
;; (programs (MODULE PROG ...) ...)
|
||||||
|
;; (pww-varname VARNAME)
|
||||||
|
;; PATTERN is a string that may contain "*" and "?" characters to be
|
||||||
|
;; expanded into filenames. MODULE is a list of symbols naming a
|
||||||
|
;; module, such as `(srfi srfi-1)'. VARNAME is a shell-safe name to use
|
||||||
|
;; instead of "probably_wont_work", the default. This var is passed to
|
||||||
|
;; `AC_SUBST'. PROG is a string.
|
||||||
|
;;
|
||||||
|
;; Only the `files-glob' form is required.
|
||||||
|
;;
|
||||||
|
;; TODO: Write better commentary.
|
||||||
|
;; Make "please see README" configurable.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(define-module (scripts autofrisk)
|
||||||
|
:autoload (ice-9 popen) (open-input-pipe)
|
||||||
|
:use-module (srfi srfi-1)
|
||||||
|
:use-module (srfi srfi-8)
|
||||||
|
:use-module (srfi srfi-13)
|
||||||
|
:use-module (srfi srfi-14)
|
||||||
|
:use-module (scripts read-scheme-source)
|
||||||
|
:use-module (scripts frisk)
|
||||||
|
:export (autofrisk))
|
||||||
|
|
||||||
|
(define *recognized-keys* '(files-glob
|
||||||
|
non-critical-external
|
||||||
|
non-critical-internal
|
||||||
|
programs
|
||||||
|
pww-varname))
|
||||||
|
|
||||||
|
(define (canonical-configuration forms)
|
||||||
|
(let ((chk (lambda (condition . x)
|
||||||
|
(or condition (apply error "syntax error:" x)))))
|
||||||
|
(chk (list? forms) "input not a list")
|
||||||
|
(chk (every list? forms) "non-list element")
|
||||||
|
(chk (every (lambda (form) (< 1 (length form))) forms) "list too short")
|
||||||
|
(let ((un #f))
|
||||||
|
(chk (every (lambda (form)
|
||||||
|
(let ((key (car form)))
|
||||||
|
(and (symbol? key)
|
||||||
|
(or (eq? 'quote key)
|
||||||
|
(memq key *recognized-keys*)
|
||||||
|
(begin
|
||||||
|
(set! un key)
|
||||||
|
#f)))))
|
||||||
|
forms)
|
||||||
|
"unrecognized key:" un))
|
||||||
|
(let ((bunched (map (lambda (key)
|
||||||
|
(fold (lambda (form so-far)
|
||||||
|
(or (and (eq? (car form) key)
|
||||||
|
(cdr form)
|
||||||
|
(append so-far (cdr form)))
|
||||||
|
so-far))
|
||||||
|
(list key)
|
||||||
|
forms))
|
||||||
|
*recognized-keys*)))
|
||||||
|
(lambda (key)
|
||||||
|
(assq-ref bunched key)))))
|
||||||
|
|
||||||
|
(define (>>strong modules)
|
||||||
|
(for-each (lambda (module)
|
||||||
|
(format #t "GUILE_MODULE_REQUIRED~A\n" module))
|
||||||
|
modules))
|
||||||
|
|
||||||
|
(define (safe-name module)
|
||||||
|
(let ((var (object->string module)))
|
||||||
|
(string-map! (lambda (c)
|
||||||
|
(if (char-set-contains? char-set:letter+digit c)
|
||||||
|
c
|
||||||
|
#\_))
|
||||||
|
var)
|
||||||
|
var))
|
||||||
|
|
||||||
|
(define *pww* "probably_wont_work")
|
||||||
|
|
||||||
|
(define (>>weak weak-edges)
|
||||||
|
(for-each (lambda (edge)
|
||||||
|
(let* ((up (edge-up edge))
|
||||||
|
(down (edge-down edge))
|
||||||
|
(var (format #f "have_guile_module~A" (safe-name up))))
|
||||||
|
(format #t "GUILE_MODULE_AVAILABLE(~A, ~A)\n" var up)
|
||||||
|
(format #t "test \"$~A\" = no &&\n ~A=\"~A $~A\"~A"
|
||||||
|
var *pww* down *pww* "\n\n")))
|
||||||
|
weak-edges))
|
||||||
|
|
||||||
|
(define (>>program module progs)
|
||||||
|
(let ((vars (map (lambda (prog)
|
||||||
|
(format #f "guile_module~Asupport_~A"
|
||||||
|
(safe-name module)
|
||||||
|
prog))
|
||||||
|
progs)))
|
||||||
|
(for-each (lambda (var prog)
|
||||||
|
(format #t "AC_PATH_PROG(~A, ~A)\n" var prog))
|
||||||
|
vars progs)
|
||||||
|
(format #t "test \\\n")
|
||||||
|
(for-each (lambda (var)
|
||||||
|
(format #t " \"$~A\" = \"\" -o \\\n" var))
|
||||||
|
vars)
|
||||||
|
(format #t "~A &&\n~A=\"~A $~A\"\n\n"
|
||||||
|
(list-ref (list "war = peace"
|
||||||
|
"freedom = slavery"
|
||||||
|
"ignorance = strength")
|
||||||
|
(random 3))
|
||||||
|
*pww* module *pww*)))
|
||||||
|
|
||||||
|
(define (>>programs programs)
|
||||||
|
(for-each (lambda (form)
|
||||||
|
(>>program (car form) (cdr form)))
|
||||||
|
programs))
|
||||||
|
|
||||||
|
(define (unglob pattern)
|
||||||
|
(let ((p (open-input-pipe (format #f "echo '(' ~A ')'" pattern))))
|
||||||
|
(map symbol->string (read p))))
|
||||||
|
|
||||||
|
(define (>>checks forms)
|
||||||
|
(let* ((cfg (canonical-configuration forms))
|
||||||
|
(files (apply append (map unglob (cfg 'files-glob))))
|
||||||
|
(ncx (cfg 'non-critical-external))
|
||||||
|
(nci (cfg 'non-critical-internal))
|
||||||
|
(prog (cfg 'non-critical))
|
||||||
|
(report ((make-frisker) files))
|
||||||
|
(external (report 'external)))
|
||||||
|
(let ((pww-varname (cfg 'pww-varname)))
|
||||||
|
(or (null? pww-varname) (set! *pww* (car pww-varname))))
|
||||||
|
(receive (weak strong)
|
||||||
|
(partition (lambda (module)
|
||||||
|
(or (member module ncx)
|
||||||
|
(every (lambda (i)
|
||||||
|
(member i nci))
|
||||||
|
(map edge-down (mod-down-ls module)))))
|
||||||
|
external)
|
||||||
|
(format #t "AC_DEFUN([AUTOFRISK_CHECKS],[\n\n")
|
||||||
|
(>>strong strong)
|
||||||
|
(format #t "\n~A=~S\n\n" *pww* "")
|
||||||
|
(>>weak (fold (lambda (module so-far)
|
||||||
|
(append so-far (mod-down-ls module)))
|
||||||
|
(list)
|
||||||
|
weak))
|
||||||
|
(>>programs (cfg 'programs))
|
||||||
|
(format #t "AC_SUBST(~A)\n])\n\n" *pww*))))
|
||||||
|
|
||||||
|
(define (>>summary)
|
||||||
|
(format #t
|
||||||
|
(symbol->string
|
||||||
|
'#{
|
||||||
|
AC_DEFUN([AUTOFRISK_SUMMARY],[
|
||||||
|
if test ! "$~A" = "" ; then
|
||||||
|
p=" ***"
|
||||||
|
echo "$p"
|
||||||
|
echo "$p NOTE:"
|
||||||
|
echo "$p The following modules probably won't work:"
|
||||||
|
echo "$p $~A"
|
||||||
|
echo "$p They can be installed anyway, and will work if their"
|
||||||
|
echo "$p dependencies are installed later. Please see README."
|
||||||
|
echo "$p"
|
||||||
|
fi
|
||||||
|
])
|
||||||
|
}#)
|
||||||
|
*pww* *pww*))
|
||||||
|
|
||||||
|
(define (autofrisk . args)
|
||||||
|
(let ((file (if (null? args) "modules.af" (car args))))
|
||||||
|
(or (file-exists? file)
|
||||||
|
(error "could not find input file:" file))
|
||||||
|
(with-output-to-file (format #f "~A.m4" file)
|
||||||
|
(lambda ()
|
||||||
|
(>>checks (read-scheme-source-silently file))
|
||||||
|
(>>summary)))))
|
||||||
|
|
||||||
|
(define main autofrisk)
|
||||||
|
|
||||||
|
;; Local variables:
|
||||||
|
;; eval: (put 'receive 'scheme-indent-function 2)
|
||||||
|
;; End:
|
||||||
|
|
||||||
|
;;; autofrisk ends here
|
||||||
70
scripts/display-commentary
Executable file
70
scripts/display-commentary
Executable file
|
|
@ -0,0 +1,70 @@
|
||||||
|
#!/bin/sh
|
||||||
|
# aside from this initial boilerplate, this is actually -*- scheme -*- code
|
||||||
|
main='(module-ref (resolve-module '\''(scripts display-commentary)) '\'main')'
|
||||||
|
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
|
||||||
|
!#
|
||||||
|
;;; display-commentary --- As advertized
|
||||||
|
|
||||||
|
;; Copyright (C) 2001 Free Software Foundation, Inc.
|
||||||
|
;;
|
||||||
|
;; This program is free software; you can redistribute it and/or
|
||||||
|
;; modify it under the terms of the GNU General Public License as
|
||||||
|
;; published by the Free Software Foundation; either version 2, or
|
||||||
|
;; (at your option) any later version.
|
||||||
|
;;
|
||||||
|
;; This program is distributed in the hope that it will be useful,
|
||||||
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||||
|
;; General Public License for more details.
|
||||||
|
;;
|
||||||
|
;; You should have received a copy of the GNU General Public License
|
||||||
|
;; along with this software; see the file COPYING. If not, write to
|
||||||
|
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||||
|
;; Boston, MA 02111-1307 USA
|
||||||
|
|
||||||
|
;;; Author: Thien-Thi Nguyen
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;; Usage: display-commentary REF1 REF2 ...
|
||||||
|
;;
|
||||||
|
;; Display Commentary section from REF1, REF2 and so on.
|
||||||
|
;; Each REF may be a filename or module name (list of symbols).
|
||||||
|
;; In the latter case, a filename is computed by searching `%load-path'.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(define-module (scripts display-commentary)
|
||||||
|
:use-module (ice-9 documentation)
|
||||||
|
:export (display-commentary))
|
||||||
|
|
||||||
|
(define (display-commentary-one file)
|
||||||
|
(format #t "~A commentary:\n~A" file (file-commentary file)))
|
||||||
|
|
||||||
|
(define (module-name->filename-frag ls) ; todo: export or move
|
||||||
|
(let ((ls (map symbol->string ls)))
|
||||||
|
(let loop ((ls (cdr ls)) (acc (car ls)))
|
||||||
|
(if (null? ls)
|
||||||
|
acc
|
||||||
|
(loop (cdr ls) (string-append acc "/" (car ls)))))))
|
||||||
|
|
||||||
|
(define (display-module-commentary module-name)
|
||||||
|
(cond ((%search-load-path (module-name->filename-frag module-name))
|
||||||
|
=> (lambda (file)
|
||||||
|
(format #t "module ~A\n" module-name)
|
||||||
|
(display-commentary-one file)))))
|
||||||
|
|
||||||
|
(define (display-commentary . refs)
|
||||||
|
(for-each (lambda (ref)
|
||||||
|
(cond ((string? ref)
|
||||||
|
(if (equal? 0 (string-index ref #\())
|
||||||
|
(display-module-commentary
|
||||||
|
(with-input-from-string ref read))
|
||||||
|
(display-commentary-one ref)))
|
||||||
|
((list? ref)
|
||||||
|
(display-module-commentary ref))))
|
||||||
|
refs))
|
||||||
|
|
||||||
|
(define main display-commentary)
|
||||||
|
|
||||||
|
;;; display-commentary ends here
|
||||||
442
scripts/doc-snarf
Executable file
442
scripts/doc-snarf
Executable file
|
|
@ -0,0 +1,442 @@
|
||||||
|
#!/bin/sh
|
||||||
|
# aside from this initial boilerplate, this is actually -*- scheme -*- code
|
||||||
|
main='(module-ref (resolve-module '\''(scripts doc-snarf)) '\'main')'
|
||||||
|
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
|
||||||
|
!#
|
||||||
|
;;; doc-snarf --- Extract documentation from source files
|
||||||
|
|
||||||
|
;; Copyright (C) 2001 Free Software Foundation, Inc.
|
||||||
|
;;
|
||||||
|
;; This program is free software; you can redistribute it and/or
|
||||||
|
;; modify it under the terms of the GNU General Public License as
|
||||||
|
;; published by the Free Software Foundation; either version 2, or
|
||||||
|
;; (at your option) any later version.
|
||||||
|
;;
|
||||||
|
;; This program is distributed in the hope that it will be useful,
|
||||||
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||||
|
;; General Public License for more details.
|
||||||
|
;;
|
||||||
|
;; You should have received a copy of the GNU General Public License
|
||||||
|
;; along with this software; see the file COPYING. If not, write to
|
||||||
|
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||||
|
;; Boston, MA 02111-1307 USA
|
||||||
|
|
||||||
|
;;; Author: Martin Grabmueller
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;; Usage: doc-snarf FILE
|
||||||
|
;;
|
||||||
|
;; This program reads in a Scheme source file and extracts docstrings
|
||||||
|
;; in the format specified below. Additionally, a procedure protoype
|
||||||
|
;; is infered from the procedure definition line starting with
|
||||||
|
;; (define... ).
|
||||||
|
;;
|
||||||
|
;; Currently, two output modi are implemented: texinfo and plaintext.
|
||||||
|
;; Default is plaintext, texinfo can be switched on with the
|
||||||
|
;; `--texinfo, -t' command line option.
|
||||||
|
;;
|
||||||
|
;; Format: A docstring can span multiple lines and a docstring line
|
||||||
|
;; begins with `;; ' (two semicoli and a space). A docstring is ended
|
||||||
|
;; by either a line beginning with (define ...) or one or more lines
|
||||||
|
;; beginning with `;;-' (two semicoli and a dash). These lines are
|
||||||
|
;; called `options' and begin with a keyword, followed by a colon and
|
||||||
|
;; a string.
|
||||||
|
;;
|
||||||
|
;; Additionally, "standard internal docstrings" (for Scheme source) are
|
||||||
|
;; recognized and output as "options". The output formatting is likely
|
||||||
|
;; to change in the future.
|
||||||
|
;;
|
||||||
|
;; Example:
|
||||||
|
|
||||||
|
;; This procedure foos, or bars, depending on the argument @var{braz}.
|
||||||
|
;;-Author: Martin Grabmueller
|
||||||
|
(define (foo/bar braz)
|
||||||
|
(if braz 'foo 'bar))
|
||||||
|
|
||||||
|
;;; Which results in the following docstring if texinfo output is
|
||||||
|
;;; enabled:
|
||||||
|
#!
|
||||||
|
foo/bar
|
||||||
|
@deffn procedure foo/bar braz
|
||||||
|
This procedure foos, or bars, depending on the argument @var{braz}.
|
||||||
|
@c Author: Martin Grabmueller
|
||||||
|
@end deffn
|
||||||
|
!#
|
||||||
|
|
||||||
|
;;; Or in this if plaintext output is used:
|
||||||
|
#!
|
||||||
|
Procedure: foo/bar braz
|
||||||
|
This procedure foos, or bars, depending on the argument @var{braz}.
|
||||||
|
;; Author: Martin Grabmueller
|
||||||
|
^L
|
||||||
|
!#
|
||||||
|
|
||||||
|
;; TODO: Convert option lines to alist.
|
||||||
|
;; More parameterization.
|
||||||
|
;; ../libguile/guile-doc-snarf emulation
|
||||||
|
|
||||||
|
(define doc-snarf-version "0.0.2") ; please update before publishing!
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(define-module (scripts doc-snarf)
|
||||||
|
:use-module (ice-9 getopt-long)
|
||||||
|
:use-module (ice-9 regex)
|
||||||
|
:use-module (ice-9 string-fun)
|
||||||
|
:use-module (ice-9 rdelim)
|
||||||
|
:export (doc-snarf))
|
||||||
|
|
||||||
|
(define command-synopsis
|
||||||
|
'((version (single-char #\v) (value #f))
|
||||||
|
(help (single-char #\h) (value #f))
|
||||||
|
(output (single-char #\o) (value #t))
|
||||||
|
(texinfo (single-char #\t) (value #f))
|
||||||
|
(lang (single-char #\l) (value #t))))
|
||||||
|
|
||||||
|
;; Display version information and exit.
|
||||||
|
;;-ttn-mod: use var
|
||||||
|
(define (display-version)
|
||||||
|
(display "doc-snarf ") (display doc-snarf-version) (newline))
|
||||||
|
|
||||||
|
;; Display the usage help message and exit.
|
||||||
|
;;-ttn-mod: change option "source" to "lang"
|
||||||
|
(define (display-help)
|
||||||
|
(display "Usage: doc-snarf [options...] inputfile\n")
|
||||||
|
(display " --help, -h Show this usage information\n")
|
||||||
|
(display " --version, -v Show version information\n")
|
||||||
|
(display
|
||||||
|
" --output=FILE, -o Specify output file [default=stdout]\n")
|
||||||
|
(display " --texinfo, -t Format output as texinfo\n")
|
||||||
|
(display " --lang=[c,scheme], -l Specify the input language\n"))
|
||||||
|
|
||||||
|
;; Main program.
|
||||||
|
;;-ttn-mod: canonicalize lang
|
||||||
|
(define (doc-snarf . args)
|
||||||
|
(let ((options (getopt-long (cons "doc-snarf" args) command-synopsis)))
|
||||||
|
(let ((help-wanted (option-ref options 'help #f))
|
||||||
|
(version-wanted (option-ref options 'version #f))
|
||||||
|
(texinfo-wanted (option-ref options 'texinfo #f))
|
||||||
|
(lang (string->symbol
|
||||||
|
(string-downcase (option-ref options 'lang "scheme")))))
|
||||||
|
(cond
|
||||||
|
(version-wanted (display-version))
|
||||||
|
(help-wanted (display-help))
|
||||||
|
(else
|
||||||
|
(let ((input (option-ref options '() #f))
|
||||||
|
(output (option-ref options 'output #f)))
|
||||||
|
(if
|
||||||
|
;; Bonard B. Timmons III says `(pair? input)' alone is sufficient.
|
||||||
|
;; (and input (pair? input))
|
||||||
|
(pair? input)
|
||||||
|
(snarf-file (car input) output texinfo-wanted lang)
|
||||||
|
(display-help))))))))
|
||||||
|
|
||||||
|
(define main doc-snarf)
|
||||||
|
|
||||||
|
;; Supported languages and their parameters. Each element has form:
|
||||||
|
;; (LANG DOC-START DOC-END DOC-PREFIX OPT-PREFIX SIG-START STD-INT-DOC?)
|
||||||
|
;; LANG is a symbol, STD-INT-DOC? is a boolean indicating whether or not
|
||||||
|
;; LANG supports "standard internal docstring" (a string after the formals),
|
||||||
|
;; everything else is a string specifying a regexp.
|
||||||
|
;;-ttn-mod: new var
|
||||||
|
(define supported-languages
|
||||||
|
'((c
|
||||||
|
"^/\\*(.*)"
|
||||||
|
"^ \\*/"
|
||||||
|
"^ \\* (.*)"
|
||||||
|
"^ \\*-(.*)"
|
||||||
|
"NOTHING AT THIS TIME!!!"
|
||||||
|
#f
|
||||||
|
)
|
||||||
|
(scheme
|
||||||
|
"^;; (.*)"
|
||||||
|
"^;;\\."
|
||||||
|
"^;; (.*)"
|
||||||
|
"^;;-(.*)"
|
||||||
|
"^\\(define"
|
||||||
|
#t
|
||||||
|
)))
|
||||||
|
|
||||||
|
;; Get @var{lang}'s @var{parameter}. Both args are symbols.
|
||||||
|
;;-ttn-mod: new proc
|
||||||
|
(define (lang-parm lang parm)
|
||||||
|
(list-ref (assq-ref supported-languages lang)
|
||||||
|
(case parm
|
||||||
|
((docstring-start) 0)
|
||||||
|
((docstring-end) 1)
|
||||||
|
((docstring-prefix) 2)
|
||||||
|
((option-prefix) 3)
|
||||||
|
((signature-start) 4)
|
||||||
|
((std-int-doc?) 5))))
|
||||||
|
|
||||||
|
;; Snarf all docstrings from the file @var{input} and write them to
|
||||||
|
;; file @var{output}. Use texinfo format for the output if
|
||||||
|
;; @var{texinfo?} is true.
|
||||||
|
;;-ttn-mod: don't use string comparison, consult table instead
|
||||||
|
(define (snarf-file input output texinfo? lang)
|
||||||
|
(or (memq lang (map car supported-languages))
|
||||||
|
(error "doc-snarf: input language must be c or scheme."))
|
||||||
|
(write-output (snarf input lang) output
|
||||||
|
(if texinfo? format-texinfo format-plain)))
|
||||||
|
|
||||||
|
;; fixme: this comment is required to trigger standard internal
|
||||||
|
;; docstring snarfing... ideally, it wouldn't be necessary.
|
||||||
|
;;-ttn-mod: new proc, from snarf-docs (aren't these names fun?)
|
||||||
|
(define (find-std-int-doc line input-port)
|
||||||
|
"Unread @var{line} from @var{input-port}, then read in the entire form and
|
||||||
|
return the standard internal docstring if found. Return #f if not."
|
||||||
|
(unread-string line input-port) ; ugh
|
||||||
|
(let ((form (read input-port)))
|
||||||
|
(cond ((and (list? form) ; (define (PROC ARGS) "DOC" ...)
|
||||||
|
(< 3 (length form))
|
||||||
|
(eq? 'define (car form))
|
||||||
|
(pair? (cadr form))
|
||||||
|
(symbol? (caadr form))
|
||||||
|
(string? (caddr form)))
|
||||||
|
(caddr form))
|
||||||
|
((and (list? form) ; (define VAR (lambda ARGS "DOC" ...))
|
||||||
|
(< 2 (length form))
|
||||||
|
(eq? 'define (car form))
|
||||||
|
(symbol? (cadr form))
|
||||||
|
(list? (caddr form))
|
||||||
|
(< 3 (length (caddr form)))
|
||||||
|
(eq? 'lambda (car (caddr form)))
|
||||||
|
(string? (caddr (caddr form))))
|
||||||
|
(caddr (caddr form)))
|
||||||
|
(else #f))))
|
||||||
|
|
||||||
|
;; Split @var{string} into lines, adding @var{prefix} to each.
|
||||||
|
;;-ttn-mod: new proc
|
||||||
|
(define (split-prefixed string prefix)
|
||||||
|
(separate-fields-discarding-char
|
||||||
|
#\newline string
|
||||||
|
(lambda lines
|
||||||
|
(map (lambda (line)
|
||||||
|
(string-append prefix line))
|
||||||
|
lines))))
|
||||||
|
|
||||||
|
;; snarf input-file output-file
|
||||||
|
;; Extract docstrings from the input file @var{input}, presumed
|
||||||
|
;; to be written in language @var{lang}.
|
||||||
|
;;-Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
|
||||||
|
;;-Created: 2001-02-17
|
||||||
|
;;-ttn-mod: regluarize lang parm lookup, add "std int doc" snarfing (2 places)
|
||||||
|
(define (snarf input-file lang)
|
||||||
|
(let* ((i-p (open-input-file input-file))
|
||||||
|
(parm-regexp (lambda (parm) (make-regexp (lang-parm lang parm))))
|
||||||
|
(docstring-start (parm-regexp 'docstring-start))
|
||||||
|
(docstring-end (parm-regexp 'docstring-end))
|
||||||
|
(docstring-prefix (parm-regexp 'docstring-prefix))
|
||||||
|
(option-prefix (parm-regexp 'option-prefix))
|
||||||
|
(signature-start (parm-regexp 'signature-start))
|
||||||
|
(augmented-options
|
||||||
|
(lambda (line i-p options)
|
||||||
|
(let ((int-doc (and (lang-parm lang 'std-int-doc?)
|
||||||
|
(let ((d (find-std-int-doc line i-p)))
|
||||||
|
(and d (split-prefixed d "internal: "))))))
|
||||||
|
(if int-doc
|
||||||
|
(append (reverse int-doc) options)
|
||||||
|
options)))))
|
||||||
|
|
||||||
|
(let lp ((line (read-line i-p)) (state 'neutral) (doc-strings '())
|
||||||
|
(options '()) (entries '()) (lno 0))
|
||||||
|
(cond
|
||||||
|
((eof-object? line)
|
||||||
|
(close-input-port i-p)
|
||||||
|
(reverse entries))
|
||||||
|
|
||||||
|
;; State 'neutral: we're currently not within a docstring or
|
||||||
|
;; option section
|
||||||
|
((eq? state 'neutral)
|
||||||
|
(let ((m (regexp-exec docstring-start line)))
|
||||||
|
(if m
|
||||||
|
(lp (read-line i-p) 'doc-string
|
||||||
|
(list (match:substring m 1)) '() entries (+ lno 1))
|
||||||
|
(lp (read-line i-p) state '() '() entries (+ lno 1)))))
|
||||||
|
|
||||||
|
;; State 'doc-string: we have started reading a docstring and
|
||||||
|
;; are waiting for more, for options or for a define.
|
||||||
|
((eq? state 'doc-string)
|
||||||
|
(let ((m0 (regexp-exec docstring-prefix line))
|
||||||
|
(m1 (regexp-exec option-prefix line))
|
||||||
|
(m2 (regexp-exec signature-start line))
|
||||||
|
(m3 (regexp-exec docstring-end line)))
|
||||||
|
(cond
|
||||||
|
(m0
|
||||||
|
(lp (read-line i-p) 'doc-string
|
||||||
|
(cons (match:substring m0 1) doc-strings) '() entries
|
||||||
|
(+ lno 1)))
|
||||||
|
(m1
|
||||||
|
(lp (read-line i-p) 'options
|
||||||
|
doc-strings (cons (match:substring m1 1) options) entries
|
||||||
|
(+ lno 1)))
|
||||||
|
(m2
|
||||||
|
(let ((options (augmented-options line i-p options))) ; ttn-mod
|
||||||
|
(lp (read-line i-p) 'neutral '() '()
|
||||||
|
(cons (parse-entry doc-strings options line input-file lno)
|
||||||
|
entries)
|
||||||
|
(+ lno 1))))
|
||||||
|
(m3
|
||||||
|
(lp (read-line i-p) 'neutral '() '()
|
||||||
|
(cons (parse-entry doc-strings options #f input-file lno)
|
||||||
|
entries)
|
||||||
|
(+ lno 1)))
|
||||||
|
(else
|
||||||
|
(lp (read-line i-p) 'neutral '() '() entries (+ lno 1))))))
|
||||||
|
|
||||||
|
;; State 'options: We're waiting for more options or for a
|
||||||
|
;; define.
|
||||||
|
((eq? state 'options)
|
||||||
|
(let ((m1 (regexp-exec option-prefix line))
|
||||||
|
(m2 (regexp-exec signature-start line))
|
||||||
|
(m3 (regexp-exec docstring-end line)))
|
||||||
|
(cond
|
||||||
|
(m1
|
||||||
|
(lp (read-line i-p) 'options
|
||||||
|
doc-strings (cons (match:substring m1 1) options) entries
|
||||||
|
(+ lno 1)))
|
||||||
|
(m2
|
||||||
|
(let ((options (augmented-options line i-p options))) ; ttn-mod
|
||||||
|
(lp (read-line i-p) 'neutral '() '()
|
||||||
|
(cons (parse-entry doc-strings options line input-file lno)
|
||||||
|
entries)
|
||||||
|
(+ lno 1))))
|
||||||
|
(m3
|
||||||
|
(lp (read-line i-p) 'neutral '() '()
|
||||||
|
(cons (parse-entry doc-strings options #f input-file lno)
|
||||||
|
entries)
|
||||||
|
(+ lno 1)))
|
||||||
|
(else
|
||||||
|
(lp (read-line i-p) 'neutral '() '() entries (+ lno 1))))))))))
|
||||||
|
|
||||||
|
(define (make-entry symbol signature docstrings options filename line)
|
||||||
|
(vector 'entry symbol signature docstrings options filename line))
|
||||||
|
(define (entry-symbol e)
|
||||||
|
(vector-ref e 1))
|
||||||
|
(define (entry-signature e)
|
||||||
|
(vector-ref e 2))
|
||||||
|
(define (entry-docstrings e)
|
||||||
|
(vector-ref e 3))
|
||||||
|
(define (entry-options e)
|
||||||
|
(vector-ref e 4))
|
||||||
|
(define (entry-filename e)
|
||||||
|
(vector-ref e 5))
|
||||||
|
(define (entry-line e)
|
||||||
|
"This docstring will not be snarfed, unfortunately..."
|
||||||
|
(vector-ref e 6))
|
||||||
|
|
||||||
|
;; Create a docstring entry from the docstring line list
|
||||||
|
;; @var{doc-strings}, the option line list @var{options} and the
|
||||||
|
;; define line @var{def-line}
|
||||||
|
(define (parse-entry docstrings options def-line filename line-no)
|
||||||
|
; (write-line docstrings)
|
||||||
|
(cond
|
||||||
|
(def-line
|
||||||
|
(make-entry (get-symbol def-line)
|
||||||
|
(make-prototype def-line) (reverse docstrings)
|
||||||
|
(reverse options) filename
|
||||||
|
(+ (- line-no (length docstrings) (length options)) 1)))
|
||||||
|
((> (length docstrings) 0)
|
||||||
|
(make-entry (string->symbol (car (reverse docstrings)))
|
||||||
|
(car (reverse docstrings))
|
||||||
|
(cdr (reverse docstrings))
|
||||||
|
(reverse options) filename
|
||||||
|
(+ (- line-no (length docstrings) (length options)) 1)))
|
||||||
|
(else
|
||||||
|
(make-entry 'foo "" (reverse docstrings) (reverse options) filename
|
||||||
|
(+ (- line-no (length docstrings) (length options)) 1)))))
|
||||||
|
|
||||||
|
;; Create a string which is a procedure prototype. The necessary
|
||||||
|
;; information for constructing the prototype is taken from the line
|
||||||
|
;; @var{def-line}, which is a line starting with @code{(define...}.
|
||||||
|
(define (make-prototype def-line)
|
||||||
|
(call-with-input-string
|
||||||
|
def-line
|
||||||
|
(lambda (s-p)
|
||||||
|
(let* ((paren (read-char s-p))
|
||||||
|
(keyword (read s-p))
|
||||||
|
(tmp (read s-p)))
|
||||||
|
(cond
|
||||||
|
((pair? tmp)
|
||||||
|
(join-symbols tmp))
|
||||||
|
((symbol? tmp)
|
||||||
|
(symbol->string tmp))
|
||||||
|
(else
|
||||||
|
""))))))
|
||||||
|
|
||||||
|
(define (get-symbol def-line)
|
||||||
|
(call-with-input-string
|
||||||
|
def-line
|
||||||
|
(lambda (s-p)
|
||||||
|
(let* ((paren (read-char s-p))
|
||||||
|
(keyword (read s-p))
|
||||||
|
(tmp (read s-p)))
|
||||||
|
(cond
|
||||||
|
((pair? tmp)
|
||||||
|
(car tmp))
|
||||||
|
((symbol? tmp)
|
||||||
|
tmp)
|
||||||
|
(else
|
||||||
|
'foo))))))
|
||||||
|
|
||||||
|
;; Append the symbols in the string list @var{s}, separated with a
|
||||||
|
;; space character.
|
||||||
|
(define (join-symbols s)
|
||||||
|
(cond ((null? s)
|
||||||
|
"")
|
||||||
|
((symbol? s)
|
||||||
|
(string-append ". " (symbol->string s)))
|
||||||
|
((null? (cdr s))
|
||||||
|
(symbol->string (car s)))
|
||||||
|
(else
|
||||||
|
(string-append (symbol->string (car s)) " " (join-symbols (cdr s))))))
|
||||||
|
|
||||||
|
;; Write @var{entries} to @var{output-file} using @var{writer}.
|
||||||
|
;; @var{writer} is a proc that takes one entry.
|
||||||
|
;; If @var{output-file} is #f, write to stdout.
|
||||||
|
;;-ttn-mod: new proc
|
||||||
|
(define (write-output entries output-file writer)
|
||||||
|
(with-output-to-port (cond (output-file (open-output-file output-file))
|
||||||
|
(else (current-output-port)))
|
||||||
|
(lambda () (for-each writer entries))))
|
||||||
|
|
||||||
|
;; Write an @var{entry} using texinfo format.
|
||||||
|
;;-ttn-mod: renamed from `texinfo-output', distilled
|
||||||
|
(define (format-texinfo entry)
|
||||||
|
(display "\n\f")
|
||||||
|
(display (entry-symbol entry))
|
||||||
|
(newline)
|
||||||
|
(display "@c snarfed from ")
|
||||||
|
(display (entry-filename entry))
|
||||||
|
(display ":")
|
||||||
|
(display (entry-line entry))
|
||||||
|
(newline)
|
||||||
|
(display "@deffn procedure ")
|
||||||
|
(display (entry-signature entry))
|
||||||
|
(newline)
|
||||||
|
(for-each (lambda (s) (write-line s))
|
||||||
|
(entry-docstrings entry))
|
||||||
|
(for-each (lambda (s) (display "@c ") (write-line s))
|
||||||
|
(entry-options entry))
|
||||||
|
(write-line "@end deffn"))
|
||||||
|
|
||||||
|
;; Write an @var{entry} using plain format.
|
||||||
|
;;-ttn-mod: renamed from `texinfo-output', distilled
|
||||||
|
(define (format-plain entry)
|
||||||
|
(display "Procedure: ")
|
||||||
|
(display (entry-signature entry))
|
||||||
|
(newline)
|
||||||
|
(for-each (lambda (s) (write-line s))
|
||||||
|
(entry-docstrings entry))
|
||||||
|
(for-each (lambda (s) (display ";; ") (write-line s))
|
||||||
|
(entry-options entry))
|
||||||
|
(display "Snarfed from ")
|
||||||
|
(display (entry-filename entry))
|
||||||
|
(display ":")
|
||||||
|
(display (entry-line entry))
|
||||||
|
(newline)
|
||||||
|
(write-line "\f"))
|
||||||
|
|
||||||
|
;;; doc-snarf ends here
|
||||||
292
scripts/frisk
Executable file
292
scripts/frisk
Executable file
|
|
@ -0,0 +1,292 @@
|
||||||
|
#!/bin/sh
|
||||||
|
# aside from this initial boilerplate, this is actually -*- scheme -*- code
|
||||||
|
main='(module-ref (resolve-module '\''(scripts frisk)) '\'main')'
|
||||||
|
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
|
||||||
|
!#
|
||||||
|
;;; frisk --- Grok the module interfaces of a body of files
|
||||||
|
|
||||||
|
;; Copyright (C) 2002 Free Software Foundation, Inc.
|
||||||
|
;;
|
||||||
|
;; This program is free software; you can redistribute it and/or
|
||||||
|
;; modify it under the terms of the GNU General Public License as
|
||||||
|
;; published by the Free Software Foundation; either version 2, or
|
||||||
|
;; (at your option) any later version.
|
||||||
|
;;
|
||||||
|
;; This program is distributed in the hope that it will be useful,
|
||||||
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||||
|
;; General Public License for more details.
|
||||||
|
;;
|
||||||
|
;; You should have received a copy of the GNU General Public License
|
||||||
|
;; along with this software; see the file COPYING. If not, write to
|
||||||
|
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||||
|
;; Boston, MA 02111-1307 USA
|
||||||
|
|
||||||
|
;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;; Usage: frisk [options] file ...
|
||||||
|
;;
|
||||||
|
;; Analyze FILE... module interfaces in aggregate (as a "body"),
|
||||||
|
;; and display a summary. Modules that are `define-module'd are
|
||||||
|
;; considered "internal" (and those not, "external"). When module X
|
||||||
|
;; uses module Y, X is said to be "(a) downstream of" Y, and Y is
|
||||||
|
;; "(an) upstream of" X.
|
||||||
|
;;
|
||||||
|
;; Normally, the summary displays external modules and their internal
|
||||||
|
;; downstreams, as this is the usual question asked by a body. There
|
||||||
|
;; are several options that modify this output.
|
||||||
|
;;
|
||||||
|
;; -u, --upstream show upstream edges
|
||||||
|
;; -d, --downstream show downstream edges (default)
|
||||||
|
;; -i, --internal show internal modules
|
||||||
|
;; -x, --external show external modules (default)
|
||||||
|
;;
|
||||||
|
;; If given both `upstream' and `downstream' options ("frisk -ud"), the
|
||||||
|
;; output is formatted: "C MODULE --- UP-LS --- DOWN-LS", where C is
|
||||||
|
;; either `i' or `x', and each element of UP-LS and DOWN-LS is (TYPE
|
||||||
|
;; MODULE-NAME ...).
|
||||||
|
;;
|
||||||
|
;; In all other cases, the "C MODULE" occupies its own line, and
|
||||||
|
;; subsequent lines list the up- or downstream edges, respectively,
|
||||||
|
;; indented by some non-zero amount of whitespace.
|
||||||
|
;;
|
||||||
|
;; Top-level `use-modules' (or `load' or 'primitive-load') forms in a
|
||||||
|
;; file that do not follow a `define-module' result an edge where the
|
||||||
|
;; downstream is the "default module", normally `(guile-user)'. This
|
||||||
|
;; can be set to another value by using:
|
||||||
|
;;
|
||||||
|
;; -m, --default-module MOD set MOD as the default module
|
||||||
|
|
||||||
|
;; Usage from a Scheme Program: (use-modules (scripts frisk))
|
||||||
|
;;
|
||||||
|
;; Module export list:
|
||||||
|
;; (frisk . args)
|
||||||
|
;; (make-frisker . options) => (lambda (files) ...) [see below]
|
||||||
|
;; (mod-up-ls module) => upstream edges
|
||||||
|
;; (mod-down-ls module) => downstream edges
|
||||||
|
;; (mod-int? module) => is the module internal?
|
||||||
|
;; (edge-type edge) => symbol: {regular,autoload,computed}
|
||||||
|
;; (edge-up edge) => upstream module
|
||||||
|
;; (edge-down edge) => downstream module
|
||||||
|
;;
|
||||||
|
;; OPTIONS is an alist. Recognized keys are:
|
||||||
|
;; default-module
|
||||||
|
;;
|
||||||
|
;; `make-frisker' returns a procedure that takes a list of files, the
|
||||||
|
;; FRISKER. FRISKER returns a closure, REPORT, that takes one of the
|
||||||
|
;; keys:
|
||||||
|
;; modules -- entire list of modules
|
||||||
|
;; internal -- list of internal modules
|
||||||
|
;; external -- list of external modules
|
||||||
|
;; i-up -- list of modules upstream of internal modules
|
||||||
|
;; x-up -- list of modules upstream of external modules
|
||||||
|
;; i-down -- list of modules downstream of internal modules
|
||||||
|
;; x-down -- list of modules downstream of external modules
|
||||||
|
;; edges -- list of edges
|
||||||
|
;; Note that `x-up' should always be null, since by (lack of!)
|
||||||
|
;; definition, we only know external modules by reference.
|
||||||
|
;;
|
||||||
|
;; The module and edge objects managed by REPORT can be examined in
|
||||||
|
;; detail by using the other (self-explanatory) procedures. Be careful
|
||||||
|
;; not to confuse a freshly consed list of symbols, like `(a b c)' with
|
||||||
|
;; the module `(a b c)'. If you want to find the module by that name,
|
||||||
|
;; try: (cond ((member '(a b c) (REPORT 'modules)) => car)).
|
||||||
|
|
||||||
|
;; TODO: Make "frisk -ud" output less ugly.
|
||||||
|
;; Consider default module as internal; add option to invert.
|
||||||
|
;; Support `edge-misc' data.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(define-module (scripts frisk)
|
||||||
|
:autoload (ice-9 getopt-long) (getopt-long)
|
||||||
|
:use-module ((srfi srfi-1) :select (filter remove))
|
||||||
|
:export (frisk
|
||||||
|
make-frisker
|
||||||
|
mod-up-ls mod-down-ls mod-int?
|
||||||
|
edge-type edge-up edge-down))
|
||||||
|
|
||||||
|
(define *default-module* '(guile-user))
|
||||||
|
|
||||||
|
(define (grok-proc default-module note-use!)
|
||||||
|
(lambda (filename)
|
||||||
|
(let* ((p (open-file filename "r"))
|
||||||
|
(next (lambda () (read p)))
|
||||||
|
(ferret (lambda (use) ;;; handle "((foo bar) :select ...)"
|
||||||
|
(let ((maybe (car use)))
|
||||||
|
(if (list? maybe)
|
||||||
|
maybe
|
||||||
|
use))))
|
||||||
|
(curmod #f))
|
||||||
|
(let loop ((form (next)))
|
||||||
|
(cond ((eof-object? form))
|
||||||
|
((not (list? form)) (loop (next)))
|
||||||
|
(else (case (car form)
|
||||||
|
((define-module)
|
||||||
|
(let ((module (cadr form)))
|
||||||
|
(set! curmod module)
|
||||||
|
(note-use! 'def module #f)
|
||||||
|
(let loop ((ls form))
|
||||||
|
(or (null? ls)
|
||||||
|
(case (car ls)
|
||||||
|
((:use-module)
|
||||||
|
(note-use! 'regular module (ferret (cadr ls)))
|
||||||
|
(loop (cddr ls)))
|
||||||
|
((:autoload)
|
||||||
|
(note-use! 'autoload module (cadr ls))
|
||||||
|
(loop (cdddr ls)))
|
||||||
|
(else (loop (cdr ls))))))))
|
||||||
|
((use-modules)
|
||||||
|
(for-each (lambda (use)
|
||||||
|
(note-use! 'regular
|
||||||
|
(or curmod default-module)
|
||||||
|
(ferret use)))
|
||||||
|
(cdr form)))
|
||||||
|
((load primitive-load)
|
||||||
|
(note-use! 'computed
|
||||||
|
(or curmod default-module)
|
||||||
|
(let ((file (cadr form)))
|
||||||
|
(if (string? file)
|
||||||
|
file
|
||||||
|
(format #f "[computed in ~A]"
|
||||||
|
filename))))))
|
||||||
|
(loop (next))))))))
|
||||||
|
|
||||||
|
(define up-ls (make-object-property)) ; list
|
||||||
|
(define dn-ls (make-object-property)) ; list
|
||||||
|
(define int? (make-object-property)) ; defined via `define-module'
|
||||||
|
|
||||||
|
(define mod-up-ls up-ls)
|
||||||
|
(define mod-down-ls dn-ls)
|
||||||
|
(define mod-int? int?)
|
||||||
|
|
||||||
|
(define (i-or-x module)
|
||||||
|
(if (int? module) 'i 'x))
|
||||||
|
|
||||||
|
(define edge-type (make-object-property)) ; symbol
|
||||||
|
|
||||||
|
(define (make-edge type up down)
|
||||||
|
(let ((new (cons up down)))
|
||||||
|
(set! (edge-type new) type)
|
||||||
|
new))
|
||||||
|
|
||||||
|
(define edge-up car)
|
||||||
|
(define edge-down cdr)
|
||||||
|
|
||||||
|
(define (up-ls+! m new) (set! (up-ls m) (cons new (up-ls m))))
|
||||||
|
(define (dn-ls+! m new) (set! (dn-ls m) (cons new (dn-ls m))))
|
||||||
|
|
||||||
|
(define (make-body alist)
|
||||||
|
(lambda (key)
|
||||||
|
(assq-ref alist key)))
|
||||||
|
|
||||||
|
(define (scan default-module files)
|
||||||
|
(let* ((modules (list))
|
||||||
|
(edges (list))
|
||||||
|
(intern (lambda (module)
|
||||||
|
(cond ((member module modules) => car)
|
||||||
|
(else (set! (up-ls module) (list))
|
||||||
|
(set! (dn-ls module) (list))
|
||||||
|
(set! modules (cons module modules))
|
||||||
|
module))))
|
||||||
|
(grok (grok-proc default-module
|
||||||
|
(lambda (type d u)
|
||||||
|
(let ((d (intern d)))
|
||||||
|
(if (eq? type 'def)
|
||||||
|
(set! (int? d) #t)
|
||||||
|
(let* ((u (intern u))
|
||||||
|
(edge (make-edge type u d)))
|
||||||
|
(set! edges (cons edge edges))
|
||||||
|
(up-ls+! d edge)
|
||||||
|
(dn-ls+! u edge))))))))
|
||||||
|
(for-each grok files)
|
||||||
|
(make-body
|
||||||
|
`((modules . ,modules)
|
||||||
|
(internal . ,(filter int? modules))
|
||||||
|
(external . ,(remove int? modules))
|
||||||
|
(i-up . ,(filter int? (map edge-down edges)))
|
||||||
|
(x-up . ,(remove int? (map edge-down edges)))
|
||||||
|
(i-down . ,(filter int? (map edge-up edges)))
|
||||||
|
(x-down . ,(remove int? (map edge-up edges)))
|
||||||
|
(edges . ,edges)))))
|
||||||
|
|
||||||
|
(define (make-frisker . options)
|
||||||
|
(let ((default-module (or (assq-ref options 'default-module)
|
||||||
|
*default-module*)))
|
||||||
|
(lambda (files)
|
||||||
|
(scan default-module files))))
|
||||||
|
|
||||||
|
(define (dump-updown modules)
|
||||||
|
(for-each (lambda (m)
|
||||||
|
(format #t "~A ~A --- ~A --- ~A\n"
|
||||||
|
(i-or-x m) m
|
||||||
|
(map (lambda (edge)
|
||||||
|
(cons (edge-type edge)
|
||||||
|
(edge-up edge)))
|
||||||
|
(up-ls m))
|
||||||
|
(map (lambda (edge)
|
||||||
|
(cons (edge-type edge)
|
||||||
|
(edge-down edge)))
|
||||||
|
(dn-ls m))))
|
||||||
|
modules))
|
||||||
|
|
||||||
|
(define (dump-up modules)
|
||||||
|
(for-each (lambda (m)
|
||||||
|
(format #t "~A ~A\n" (i-or-x m) m)
|
||||||
|
(for-each (lambda (edge)
|
||||||
|
(format #t "\t\t\t ~A\t~A\n"
|
||||||
|
(edge-type edge) (edge-up edge)))
|
||||||
|
(up-ls m)))
|
||||||
|
modules))
|
||||||
|
|
||||||
|
(define (dump-down modules)
|
||||||
|
(for-each (lambda (m)
|
||||||
|
(format #t "~A ~A\n" (i-or-x m) m)
|
||||||
|
(for-each (lambda (edge)
|
||||||
|
(format #t "\t\t\t ~A\t~A\n"
|
||||||
|
(edge-type edge) (edge-down edge)))
|
||||||
|
(dn-ls m)))
|
||||||
|
modules))
|
||||||
|
|
||||||
|
(define (frisk . args)
|
||||||
|
(let* ((parsed-opts (getopt-long
|
||||||
|
(cons "frisk" args) ;;; kludge
|
||||||
|
'((upstream (single-char #\u))
|
||||||
|
(downstream (single-char #\d))
|
||||||
|
(internal (single-char #\i))
|
||||||
|
(external (single-char #\x))
|
||||||
|
(default-module
|
||||||
|
(single-char #\m)
|
||||||
|
(value #t)))))
|
||||||
|
(=u (option-ref parsed-opts 'upstream #f))
|
||||||
|
(=d (option-ref parsed-opts 'downstream #f))
|
||||||
|
(=i (option-ref parsed-opts 'internal #f))
|
||||||
|
(=x (option-ref parsed-opts 'external #f))
|
||||||
|
(files (option-ref parsed-opts '() (list)))
|
||||||
|
(report ((make-frisker
|
||||||
|
`(default-module
|
||||||
|
. ,(option-ref parsed-opts 'default-module
|
||||||
|
*default-module*)))
|
||||||
|
files))
|
||||||
|
(modules (report 'modules))
|
||||||
|
(internal (report 'internal))
|
||||||
|
(external (report 'external))
|
||||||
|
(edges (report 'edges)))
|
||||||
|
(format #t "~A ~A, ~A ~A (~A ~A, ~A ~A), ~A ~A\n\n"
|
||||||
|
(length files) "files"
|
||||||
|
(length modules) "modules"
|
||||||
|
(length internal) "internal"
|
||||||
|
(length external) "external"
|
||||||
|
(length edges) "edges")
|
||||||
|
((cond ((and =u =d) dump-updown)
|
||||||
|
(=u dump-up)
|
||||||
|
(else dump-down))
|
||||||
|
(cond ((and =i =x) modules)
|
||||||
|
(=i internal)
|
||||||
|
(else external)))))
|
||||||
|
|
||||||
|
(define main frisk)
|
||||||
|
|
||||||
|
;;; frisk ends here
|
||||||
146
scripts/generate-autoload
Executable file
146
scripts/generate-autoload
Executable file
|
|
@ -0,0 +1,146 @@
|
||||||
|
#!/bin/sh
|
||||||
|
# aside from this initial boilerplate, this is actually -*- scheme -*- code
|
||||||
|
main='(module-ref (resolve-module '\''(scripts generate-autoload)) '\'main')'
|
||||||
|
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
|
||||||
|
!#
|
||||||
|
;;; generate-autoload --- Display define-module form with autoload info
|
||||||
|
|
||||||
|
;; Copyright (C) 2001 Free Software Foundation, Inc.
|
||||||
|
;;
|
||||||
|
;; This program is free software; you can redistribute it and/or
|
||||||
|
;; modify it under the terms of the GNU General Public License as
|
||||||
|
;; published by the Free Software Foundation; either version 2, or
|
||||||
|
;; (at your option) any later version.
|
||||||
|
;;
|
||||||
|
;; This program is distributed in the hope that it will be useful,
|
||||||
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||||
|
;; General Public License for more details.
|
||||||
|
;;
|
||||||
|
;; You should have received a copy of the GNU General Public License
|
||||||
|
;; along with this software; see the file COPYING. If not, write to
|
||||||
|
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||||
|
;; Boston, MA 02111-1307 USA
|
||||||
|
|
||||||
|
;;; Author: Thien-Thi Nguyen
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;; Usage: generate-autoload [OPTIONS] FILE1 FILE2 ...
|
||||||
|
;;
|
||||||
|
;; The autoload form is displayed to standard output:
|
||||||
|
;;
|
||||||
|
;; (define-module (guile-user)
|
||||||
|
;; :autoload (ZAR FOO) (FOO-1 FOO-2 ...)
|
||||||
|
;; :
|
||||||
|
;; :
|
||||||
|
;; :autoload (ZAR BAR) (BAR-1 BAR-2 ...))
|
||||||
|
;;
|
||||||
|
;; For each file, a symbol triggers an autoload if it is found in one
|
||||||
|
;; of these situations:
|
||||||
|
;; - in the `:export' clause of a `define-module' form
|
||||||
|
;; - in a top-level `export' or `export-syntax' form
|
||||||
|
;; - in a `define-public' form
|
||||||
|
;; - in a `defmacro-public' form
|
||||||
|
;;
|
||||||
|
;; The module name is inferred from the `define-module' form. If either the
|
||||||
|
;; module name or the exports list cannot be determined, no autoload entry is
|
||||||
|
;; generated for that file.
|
||||||
|
;;
|
||||||
|
;; Options:
|
||||||
|
;; --target MODULE-NAME -- Use MODULE-NAME instead of `(guile-user)'.
|
||||||
|
;; Note that some shells may require you to
|
||||||
|
;; quote the argument to handle parentheses
|
||||||
|
;; and spaces.
|
||||||
|
;;
|
||||||
|
;; Usage examples from Scheme code as a module:
|
||||||
|
;; (use-modules (scripts generate-autoload))
|
||||||
|
;; (generate-autoload "generate-autoload")
|
||||||
|
;; (generate-autoload "--target" "(my module)" "generate-autoload")
|
||||||
|
;; (apply generate-autoload "--target" "(my module)" '("foo" "bar" "baz"))
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(define-module (scripts generate-autoload)
|
||||||
|
:export (generate-autoload))
|
||||||
|
|
||||||
|
(define (autoload-info file)
|
||||||
|
(let ((p (open-input-file file)))
|
||||||
|
(let loop ((form (read p)) (module-name #f) (exports '()))
|
||||||
|
(if (eof-object? form)
|
||||||
|
(and module-name
|
||||||
|
(not (null? exports))
|
||||||
|
(list module-name exports)) ; ret
|
||||||
|
(cond ((and (list? form)
|
||||||
|
(< 1 (length form))
|
||||||
|
(eq? 'define-module (car form)))
|
||||||
|
(loop (read p)
|
||||||
|
(cadr form)
|
||||||
|
(cond ((member ':export form)
|
||||||
|
=> (lambda (val)
|
||||||
|
(append (cadr val) exports)))
|
||||||
|
(else exports))))
|
||||||
|
((and (list? form)
|
||||||
|
(< 1 (length form))
|
||||||
|
(memq (car form) '(export export-syntax)))
|
||||||
|
(loop (read p)
|
||||||
|
module-name
|
||||||
|
(append (cdr form) exports)))
|
||||||
|
((and (list? form)
|
||||||
|
(< 2 (length form))
|
||||||
|
(eq? 'define-public (car form))
|
||||||
|
(list? (cadr form))
|
||||||
|
(symbol? (caadr form)))
|
||||||
|
(loop (read p)
|
||||||
|
module-name
|
||||||
|
(cons (caadr form) exports)))
|
||||||
|
((and (list? form)
|
||||||
|
(< 2 (length form))
|
||||||
|
(eq? 'define-public (car form))
|
||||||
|
(symbol? (cadr form)))
|
||||||
|
(loop (read p)
|
||||||
|
module-name
|
||||||
|
(cons (cadr form) exports)))
|
||||||
|
((and (list? form)
|
||||||
|
(< 3 (length form))
|
||||||
|
(eq? 'defmacro-public (car form))
|
||||||
|
(symbol? (cadr form)))
|
||||||
|
(loop (read p)
|
||||||
|
module-name
|
||||||
|
(cons (cadr form) exports)))
|
||||||
|
(else (loop (read p) module-name exports)))))))
|
||||||
|
|
||||||
|
(define (generate-autoload . args)
|
||||||
|
(let* ((module-count 0)
|
||||||
|
(syms-count 0)
|
||||||
|
(target-override (cond ((member "--target" args) => cadr)
|
||||||
|
(else #f)))
|
||||||
|
(files (if target-override (cddr args) (cdr args))))
|
||||||
|
(display ";;; do not edit --- generated ")
|
||||||
|
(display (strftime "%Y-%m-%d %H:%M:%S" (localtime (current-time))))
|
||||||
|
(newline)
|
||||||
|
(display "(define-module ")
|
||||||
|
(display (or target-override "(guile-user)"))
|
||||||
|
(for-each (lambda (file)
|
||||||
|
(cond ((autoload-info file)
|
||||||
|
=> (lambda (info)
|
||||||
|
(and info
|
||||||
|
(apply (lambda (module-name exports)
|
||||||
|
(set! module-count (1+ module-count))
|
||||||
|
(set! syms-count (+ (length exports)
|
||||||
|
syms-count))
|
||||||
|
(for-each display
|
||||||
|
(list "\n :autoload "
|
||||||
|
module-name " "
|
||||||
|
exports)))
|
||||||
|
info))))))
|
||||||
|
files)
|
||||||
|
(display ")")
|
||||||
|
(newline)
|
||||||
|
(for-each display (list " ;;; "
|
||||||
|
syms-count " symbols in "
|
||||||
|
module-count " modules\n"))))
|
||||||
|
|
||||||
|
(define main generate-autoload)
|
||||||
|
|
||||||
|
;;; generate-autoload ends here
|
||||||
319
scripts/lint
Executable file
319
scripts/lint
Executable file
|
|
@ -0,0 +1,319 @@
|
||||||
|
#!/bin/sh
|
||||||
|
# aside from this initial boilerplate, this is actually -*- scheme -*- code
|
||||||
|
main='(module-ref (resolve-module '\''(scripts lint)) '\'main')'
|
||||||
|
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
|
||||||
|
!#
|
||||||
|
;;; lint --- Preemptive checks for coding errors in Guile Scheme code
|
||||||
|
|
||||||
|
;; Copyright (C) 2002 Free Software Foundation, Inc.
|
||||||
|
;;
|
||||||
|
;; This program is free software; you can redistribute it and/or
|
||||||
|
;; modify it under the terms of the GNU General Public License as
|
||||||
|
;; published by the Free Software Foundation; either version 2, or
|
||||||
|
;; (at your option) any later version.
|
||||||
|
;;
|
||||||
|
;; This program is distributed in the hope that it will be useful,
|
||||||
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||||
|
;; General Public License for more details.
|
||||||
|
;;
|
||||||
|
;; You should have received a copy of the GNU General Public License
|
||||||
|
;; along with this software; see the file COPYING. If not, write to
|
||||||
|
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||||
|
;; Boston, MA 02111-1307 USA
|
||||||
|
|
||||||
|
;;; Author: Neil Jerram
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;; Usage: lint FILE1 FILE2 ...
|
||||||
|
;;
|
||||||
|
;; Perform various preemptive checks for coding errors in Guile Scheme
|
||||||
|
;; code.
|
||||||
|
;;
|
||||||
|
;; Right now, there is only one check available, for unresolved free
|
||||||
|
;; variables. The intention is that future lint-like checks will be
|
||||||
|
;; implemented by adding to this script file.
|
||||||
|
;;
|
||||||
|
;; Unresolved free variables
|
||||||
|
;; -------------------------
|
||||||
|
;;
|
||||||
|
;; Free variables are those whose definitions come from outside the
|
||||||
|
;; module under investigation. In Guile, these definitions are
|
||||||
|
;; imported from other modules using `#:use-module' forms.
|
||||||
|
;;
|
||||||
|
;; This tool scans the specified files for unresolved free variables -
|
||||||
|
;; i.e. variables for which you may have forgotten the appropriate
|
||||||
|
;; `#:use-module', or for which the module that is supposed to export
|
||||||
|
;; them forgot to.
|
||||||
|
;;
|
||||||
|
;; It isn't guaranteed that the scan will find absolutely all such
|
||||||
|
;; errors. Quoted (and quasiquoted) expressions are skipped, since
|
||||||
|
;; they are most commonly used to describe constant data, not code, so
|
||||||
|
;; code that is explicitly evaluated using `eval' will not be checked.
|
||||||
|
;; For example, the `unresolved-var' in `(eval 'unresolved-var
|
||||||
|
;; (current-module))' would be missed.
|
||||||
|
;;
|
||||||
|
;; False positives are also possible. Firstly, the tool doesn't
|
||||||
|
;; understand all possible forms of implicit quoting; in particular,
|
||||||
|
;; it doesn't detect and expand uses of macros. Secondly, it picks up
|
||||||
|
;; explicit compatibility code like `(if (defined? 'x) (define y x))'.
|
||||||
|
;; Thirdly, there are occasional oddities like `next-method'.
|
||||||
|
;; However, the number of false positives for realistic code is
|
||||||
|
;; hopefully small enough that they can be individually considered and
|
||||||
|
;; ignored.
|
||||||
|
;;
|
||||||
|
;; Example
|
||||||
|
;; -------
|
||||||
|
;;
|
||||||
|
;; Note: most of the unresolved variables found in this example are
|
||||||
|
;; false positives, as you would hope. => scope for improvement.
|
||||||
|
;;
|
||||||
|
;; $ guile-tools lint `guile-tools`
|
||||||
|
;; No unresolved free variables in PROGRAM
|
||||||
|
;; No unresolved free variables in autofrisk
|
||||||
|
;; No unresolved free variables in display-commentary
|
||||||
|
;; Unresolved free variables in doc-snarf:
|
||||||
|
;; doc-snarf-version
|
||||||
|
;; No unresolved free variables in frisk
|
||||||
|
;; No unresolved free variables in generate-autoload
|
||||||
|
;; No unresolved free variables in lint
|
||||||
|
;; No unresolved free variables in punify
|
||||||
|
;; No unresolved free variables in read-scheme-source
|
||||||
|
;; Unresolved free variables in snarf-check-and-output-texi:
|
||||||
|
;; name
|
||||||
|
;; pos
|
||||||
|
;; line
|
||||||
|
;; x
|
||||||
|
;; rest
|
||||||
|
;; ...
|
||||||
|
;; do-argpos
|
||||||
|
;; do-command
|
||||||
|
;; do-args
|
||||||
|
;; type
|
||||||
|
;; num
|
||||||
|
;; file
|
||||||
|
;; do-arglist
|
||||||
|
;; req
|
||||||
|
;; opt
|
||||||
|
;; var
|
||||||
|
;; command
|
||||||
|
;; do-directive
|
||||||
|
;; s
|
||||||
|
;; ?
|
||||||
|
;; No unresolved free variables in use2dot
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(define-module (scripts lint)
|
||||||
|
#:use-module (ice-9 common-list)
|
||||||
|
#:use-module (ice-9 format)
|
||||||
|
#:export (lint))
|
||||||
|
|
||||||
|
(define (lint filename)
|
||||||
|
(let ((module-name (scan-file-for-module-name filename))
|
||||||
|
(free-vars (uniq (scan-file-for-free-variables filename))))
|
||||||
|
(let ((module (resolve-module module-name))
|
||||||
|
(all-resolved? #t))
|
||||||
|
(let loop ((free-vars free-vars))
|
||||||
|
(or (null? free-vars)
|
||||||
|
(begin
|
||||||
|
(catch #t
|
||||||
|
(lambda ()
|
||||||
|
(eval (car free-vars) module))
|
||||||
|
(lambda args
|
||||||
|
(if all-resolved?
|
||||||
|
(format #t
|
||||||
|
"Unresolved free variables in ~A:\n"
|
||||||
|
filename))
|
||||||
|
(write-char #\tab)
|
||||||
|
(write (car free-vars))
|
||||||
|
(newline)
|
||||||
|
(set! all-resolved? #f)))
|
||||||
|
(loop (cdr free-vars)))))
|
||||||
|
(if all-resolved?
|
||||||
|
(format #t
|
||||||
|
"No unresolved free variables in ~A\n"
|
||||||
|
filename)))))
|
||||||
|
|
||||||
|
(define (scan-file-for-module-name filename)
|
||||||
|
(with-input-from-file filename
|
||||||
|
(lambda ()
|
||||||
|
(let loop ((x (read)))
|
||||||
|
(cond ((eof-object? x) #f)
|
||||||
|
((and (pair? x)
|
||||||
|
(eq? (car x) 'define-module))
|
||||||
|
(cadr x))
|
||||||
|
(else (loop (read))))))))
|
||||||
|
|
||||||
|
(define (scan-file-for-free-variables filename)
|
||||||
|
(with-input-from-file filename
|
||||||
|
(lambda ()
|
||||||
|
(let loop ((x (read)) (fvlists '()))
|
||||||
|
(if (eof-object? x)
|
||||||
|
(apply append fvlists)
|
||||||
|
(loop (read) (cons (detect-free-variables x '()) fvlists)))))))
|
||||||
|
|
||||||
|
; guile> (detect-free-variables '(let ((a 1)) a) '())
|
||||||
|
; ()
|
||||||
|
; guile> (detect-free-variables '(let ((a 1)) b) '())
|
||||||
|
; (b)
|
||||||
|
; guile> (detect-free-variables '(let ((a 1) (b a)) b) '())
|
||||||
|
; (a)
|
||||||
|
; guile> (detect-free-variables '(let* ((a 1) (b a)) b) '())
|
||||||
|
; ()
|
||||||
|
; guile> (detect-free-variables '(define a 1) '())
|
||||||
|
; ()
|
||||||
|
; guile> (detect-free-variables '(define a b) '())
|
||||||
|
; (b)
|
||||||
|
; guile> (detect-free-variables '(define (a b c) b) '())
|
||||||
|
; ()
|
||||||
|
; guile> (detect-free-variables '(define (a b c) e) '())
|
||||||
|
; (e)
|
||||||
|
|
||||||
|
(define (detect-free-variables x locals)
|
||||||
|
;; Given an expression @var{x} and a list @var{locals} of local
|
||||||
|
;; variables (symbols) that are in scope for @var{x}, return a list
|
||||||
|
;; of free variable symbols.
|
||||||
|
(cond ((symbol? x)
|
||||||
|
(if (memq x locals) '() (list x)))
|
||||||
|
|
||||||
|
((pair? x)
|
||||||
|
(case (car x)
|
||||||
|
((define-module define-generic quote quasiquote)
|
||||||
|
;; No code of interest in these expressions.
|
||||||
|
'())
|
||||||
|
|
||||||
|
((let letrec)
|
||||||
|
;; Check for named let. If there is a name, transform the
|
||||||
|
;; expression so that it looks like an unnamed let with
|
||||||
|
;; the name as one of the bindings.
|
||||||
|
(if (symbol? (cadr x))
|
||||||
|
(set-cdr! x (cons (cons (list (cadr x) #f) (caddr x))
|
||||||
|
(cdddr x))))
|
||||||
|
;; Unnamed let processing.
|
||||||
|
(let ((letrec? (eq? (car x) 'letrec))
|
||||||
|
(locals-for-let-body (append locals (map car (cadr x)))))
|
||||||
|
(append (apply append
|
||||||
|
(map (lambda (binding)
|
||||||
|
(detect-free-variables (cadr binding)
|
||||||
|
(if letrec?
|
||||||
|
locals-for-let-body
|
||||||
|
locals)))
|
||||||
|
(cadr x)))
|
||||||
|
(apply append
|
||||||
|
(map (lambda (bodyform)
|
||||||
|
(detect-free-variables bodyform
|
||||||
|
locals-for-let-body))
|
||||||
|
(cddr x))))))
|
||||||
|
|
||||||
|
((let* and-let*)
|
||||||
|
;; Handle bindings recursively.
|
||||||
|
(if (null? (cadr x))
|
||||||
|
(apply append
|
||||||
|
(map (lambda (bodyform)
|
||||||
|
(detect-free-variables bodyform locals))
|
||||||
|
(cddr x)))
|
||||||
|
(append (detect-free-variables (cadr (caadr x)) locals)
|
||||||
|
(detect-free-variables `(let* ,(cdadr x) ,@(cddr x))
|
||||||
|
(cons (caaadr x) locals)))))
|
||||||
|
|
||||||
|
((define define-public define-macro)
|
||||||
|
(if (pair? (cadr x))
|
||||||
|
(begin
|
||||||
|
(set! locals (cons (caadr x) locals))
|
||||||
|
(detect-free-variables `(lambda ,(cdadr x) ,@(cddr x))
|
||||||
|
locals))
|
||||||
|
(begin
|
||||||
|
(set! locals (cons (cadr x) locals))
|
||||||
|
(detect-free-variables (caddr x) locals))))
|
||||||
|
|
||||||
|
((lambda lambda*)
|
||||||
|
(let ((locals-for-lambda-body (let loop ((locals locals)
|
||||||
|
(args (cadr x)))
|
||||||
|
(cond ((null? args) locals)
|
||||||
|
((pair? args)
|
||||||
|
(loop (cons (car args) locals)
|
||||||
|
(cdr args)))
|
||||||
|
(else
|
||||||
|
(cons args locals))))))
|
||||||
|
(apply append
|
||||||
|
(map (lambda (bodyform)
|
||||||
|
(detect-free-variables bodyform
|
||||||
|
locals-for-lambda-body))
|
||||||
|
(cddr x)))))
|
||||||
|
|
||||||
|
((receive)
|
||||||
|
(let ((locals-for-receive-body (append locals (cadr x))))
|
||||||
|
(apply append
|
||||||
|
(detect-free-variables (caddr x) locals)
|
||||||
|
(map (lambda (bodyform)
|
||||||
|
(detect-free-variables bodyform
|
||||||
|
locals-for-receive-body))
|
||||||
|
(cdddr x)))))
|
||||||
|
|
||||||
|
((define-method define*)
|
||||||
|
(let ((locals-for-method-body (let loop ((locals locals)
|
||||||
|
(args (cdadr x)))
|
||||||
|
(cond ((null? args) locals)
|
||||||
|
((pair? args)
|
||||||
|
(loop (cons (if (pair? (car args))
|
||||||
|
(caar args)
|
||||||
|
(car args))
|
||||||
|
locals)
|
||||||
|
(cdr args)))
|
||||||
|
(else
|
||||||
|
(cons args locals))))))
|
||||||
|
(apply append
|
||||||
|
(map (lambda (bodyform)
|
||||||
|
(detect-free-variables bodyform
|
||||||
|
locals-for-method-body))
|
||||||
|
(cddr x)))))
|
||||||
|
|
||||||
|
((define-class)
|
||||||
|
;; Avoid picking up slot names at the start of slot
|
||||||
|
;; definitions.
|
||||||
|
(apply append
|
||||||
|
(map (lambda (slot/option)
|
||||||
|
(detect-free-variables-noncar (if (pair? slot/option)
|
||||||
|
(cdr slot/option)
|
||||||
|
slot/option)
|
||||||
|
locals))
|
||||||
|
(cdddr x))))
|
||||||
|
|
||||||
|
((case)
|
||||||
|
(apply append
|
||||||
|
(detect-free-variables (cadr x) locals)
|
||||||
|
(map (lambda (case)
|
||||||
|
(detect-free-variables (cdr case) locals))
|
||||||
|
(cddr x))))
|
||||||
|
|
||||||
|
((unquote unquote-splicing else =>)
|
||||||
|
(detect-free-variables-noncar (cdr x) locals))
|
||||||
|
|
||||||
|
(else (append (detect-free-variables (car x) locals)
|
||||||
|
(detect-free-variables-noncar (cdr x) locals)))))
|
||||||
|
|
||||||
|
(else '())))
|
||||||
|
|
||||||
|
(define (detect-free-variables-noncar x locals)
|
||||||
|
;; Given an expression @var{x} and a list @var{locals} of local
|
||||||
|
;; variables (symbols) that are in scope for @var{x}, return a list
|
||||||
|
;; of free variable symbols.
|
||||||
|
(cond ((symbol? x)
|
||||||
|
(if (memq x locals) '() (list x)))
|
||||||
|
|
||||||
|
((pair? x)
|
||||||
|
(case (car x)
|
||||||
|
((=>)
|
||||||
|
(detect-free-variables-noncar (cdr x) locals))
|
||||||
|
|
||||||
|
(else (append (detect-free-variables (car x) locals)
|
||||||
|
(detect-free-variables-noncar (cdr x) locals)))))
|
||||||
|
|
||||||
|
(else '())))
|
||||||
|
|
||||||
|
(define (main . files)
|
||||||
|
(for-each lint files))
|
||||||
|
|
||||||
|
;;; lint ends here
|
||||||
89
scripts/punify
Executable file
89
scripts/punify
Executable file
|
|
@ -0,0 +1,89 @@
|
||||||
|
#!/bin/sh
|
||||||
|
# aside from this initial boilerplate, this is actually -*- scheme -*- code
|
||||||
|
main='(module-ref (resolve-module '\''(scripts punify)) '\'main')'
|
||||||
|
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
|
||||||
|
!#
|
||||||
|
;;; punify --- Display Scheme code w/o unnecessary comments / whitespace
|
||||||
|
|
||||||
|
;; Copyright (C) 2001 Free Software Foundation, Inc.
|
||||||
|
;;
|
||||||
|
;; This program is free software; you can redistribute it and/or
|
||||||
|
;; modify it under the terms of the GNU General Public License as
|
||||||
|
;; published by the Free Software Foundation; either version 2, or
|
||||||
|
;; (at your option) any later version.
|
||||||
|
;;
|
||||||
|
;; This program is distributed in the hope that it will be useful,
|
||||||
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||||
|
;; General Public License for more details.
|
||||||
|
;;
|
||||||
|
;; You should have received a copy of the GNU General Public License
|
||||||
|
;; along with this software; see the file COPYING. If not, write to
|
||||||
|
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||||
|
;; Boston, MA 02111-1307 USA
|
||||||
|
|
||||||
|
;;; Author: Thien-Thi Nguyen
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;; Usage: punify FILE1 FILE2 ...
|
||||||
|
;;
|
||||||
|
;; Each file's forms are read and written to stdout.
|
||||||
|
;; The effect is to remove comments and much non-essential whitespace.
|
||||||
|
;; This is useful when installing Scheme source to space-limited media.
|
||||||
|
;;
|
||||||
|
;; Example:
|
||||||
|
;; $ wc ./punify ; ./punify ./punify | wc
|
||||||
|
;; 89 384 3031 ./punify
|
||||||
|
;; 0 42 920
|
||||||
|
;;
|
||||||
|
;; TODO: Read from stdin.
|
||||||
|
;; Handle vectors.
|
||||||
|
;; Identifier punification.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(define-module (scripts punify)
|
||||||
|
:export (punify))
|
||||||
|
|
||||||
|
(define (write-punily form)
|
||||||
|
(cond ((and (list? form) (not (null? form)))
|
||||||
|
(let ((first (car form)))
|
||||||
|
(display "(")
|
||||||
|
(write-punily first)
|
||||||
|
(let loop ((ls (cdr form)) (last-was-list? (list? first)))
|
||||||
|
(if (null? ls)
|
||||||
|
(display ")")
|
||||||
|
(let* ((new-first (car ls))
|
||||||
|
(this-is-list? (list? new-first)))
|
||||||
|
(and (not last-was-list?)
|
||||||
|
(not this-is-list?)
|
||||||
|
(display " "))
|
||||||
|
(write-punily new-first)
|
||||||
|
(loop (cdr ls) this-is-list?))))))
|
||||||
|
((and (symbol? form)
|
||||||
|
(let ((ls (string->list (symbol->string form))))
|
||||||
|
(and (char=? (car ls) #\:)
|
||||||
|
(not (memq #\space ls))
|
||||||
|
(list->string (cdr ls)))))
|
||||||
|
=> (lambda (symbol-name-after-colon)
|
||||||
|
(display #\:)
|
||||||
|
(display symbol-name-after-colon)))
|
||||||
|
(else (write form))))
|
||||||
|
|
||||||
|
(define (punify-one file)
|
||||||
|
(with-input-from-file file
|
||||||
|
(lambda ()
|
||||||
|
(let ((toke (lambda () (read (current-input-port)))))
|
||||||
|
(let loop ((form (toke)))
|
||||||
|
(or (eof-object? form)
|
||||||
|
(begin
|
||||||
|
(write-punily form)
|
||||||
|
(loop (toke)))))))))
|
||||||
|
|
||||||
|
(define (punify . args)
|
||||||
|
(for-each punify-one args))
|
||||||
|
|
||||||
|
(define main punify)
|
||||||
|
|
||||||
|
;;; punify ends here
|
||||||
284
scripts/read-scheme-source
Executable file
284
scripts/read-scheme-source
Executable file
|
|
@ -0,0 +1,284 @@
|
||||||
|
#!/bin/sh
|
||||||
|
# aside from this initial boilerplate, this is actually -*- scheme -*- code
|
||||||
|
main='(module-ref (resolve-module '\''(scripts read-scheme-source)) '\'main')'
|
||||||
|
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
|
||||||
|
!#
|
||||||
|
;;; read-scheme-source --- Read a file, recognizing scheme forms and comments
|
||||||
|
|
||||||
|
;; Copyright (C) 2001 Free Software Foundation, Inc.
|
||||||
|
;;
|
||||||
|
;; This program is free software; you can redistribute it and/or
|
||||||
|
;; modify it under the terms of the GNU General Public License as
|
||||||
|
;; published by the Free Software Foundation; either version 2, or
|
||||||
|
;; (at your option) any later version.
|
||||||
|
;;
|
||||||
|
;; This program is distributed in the hope that it will be useful,
|
||||||
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||||
|
;; General Public License for more details.
|
||||||
|
;;
|
||||||
|
;; You should have received a copy of the GNU General Public License
|
||||||
|
;; along with this software; see the file COPYING. If not, write to
|
||||||
|
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||||
|
;; Boston, MA 02111-1307 USA
|
||||||
|
|
||||||
|
;;; Author: Thien-Thi Nguyen
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;; Usage: read-scheme-source FILE1 FILE2 ...
|
||||||
|
;;
|
||||||
|
;; This program parses each FILE and writes to stdout sexps that describe the
|
||||||
|
;; top-level structures of the file: scheme forms, single-line comments, and
|
||||||
|
;; hash-bang comments. You can further process these (to associate comments
|
||||||
|
;; w/ scheme forms as a kind of documentation, for example).
|
||||||
|
;;
|
||||||
|
;; The output sexps have one of these forms:
|
||||||
|
;;
|
||||||
|
;; (quote (filename FILENAME))
|
||||||
|
;;
|
||||||
|
;; (quote (comment :leading-semicolons N
|
||||||
|
;; :text LINE))
|
||||||
|
;;
|
||||||
|
;; (quote (whitespace :text LINE))
|
||||||
|
;;
|
||||||
|
;; (quote (hash-bang-comment :line LINUM
|
||||||
|
;; :line-count N
|
||||||
|
;; :text-list (LINE1 LINE2 ...)))
|
||||||
|
;;
|
||||||
|
;; (quote (following-form-properties :line LINUM
|
||||||
|
;; :line-count N)
|
||||||
|
;; :type TYPE
|
||||||
|
;; :signature SIGNATURE
|
||||||
|
;; :std-int-doc DOCSTRING))
|
||||||
|
;;
|
||||||
|
;; SEXP
|
||||||
|
;;
|
||||||
|
;; The first four are straightforward (both FILENAME and LINE are strings sans
|
||||||
|
;; newline, while LINUM and N are integers). The last two always go together,
|
||||||
|
;; in that order. SEXP is scheme code processed only by `read' and then
|
||||||
|
;; `write'.
|
||||||
|
;;
|
||||||
|
;; The :type field may be omitted if the form is not recognized. Otherwise,
|
||||||
|
;; TYPE may be one of: procedure, alias, define-module, variable.
|
||||||
|
;;
|
||||||
|
;; The :signature field may be omitted if the form is not a procedure.
|
||||||
|
;; Otherwise, SIGNATURE is a list showing the procedure's signature.
|
||||||
|
;;
|
||||||
|
;; If the type is `procedure' and the form has a standard internal docstring
|
||||||
|
;; (first body form a string), that is extracted in full -- including any
|
||||||
|
;; embedded newlines -- and recorded by field :std-int-doc.
|
||||||
|
;;
|
||||||
|
;;
|
||||||
|
;; Usage from a program: The output list of sexps can be retrieved by scheme
|
||||||
|
;; programs w/o having to capture stdout, like so:
|
||||||
|
;;
|
||||||
|
;; (use-modules (scripts read-scheme-source))
|
||||||
|
;; (define source-forms (read-scheme-source-silently "FILE1" "FILE2" ...))
|
||||||
|
;;
|
||||||
|
;; There are also two convenience procs exported for use by Scheme programs:
|
||||||
|
;;
|
||||||
|
;; (clump FORMS) --- filter FORMS combining contiguous comment forms that
|
||||||
|
;; have the same number of leading semicolons.
|
||||||
|
;;
|
||||||
|
;; (quoted? SYM FORM) --- see if FORM looks like: "(quote (SYM ...))", parse
|
||||||
|
;; the ":tags", and return alist of (TAG . VAL) elems.
|
||||||
|
;;
|
||||||
|
;; TODO: Add option "--clump-comments", maybe w/ different clumping styles.
|
||||||
|
;; Make `annotate!' extensible.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(define-module (scripts read-scheme-source)
|
||||||
|
:use-module (ice-9 rdelim)
|
||||||
|
:export (read-scheme-source
|
||||||
|
read-scheme-source-silently
|
||||||
|
quoted?
|
||||||
|
clump))
|
||||||
|
|
||||||
|
;; Try to figure out what FORM is and its various attributes.
|
||||||
|
;; Call proc NOTE! with key (a symbol) and value.
|
||||||
|
;;
|
||||||
|
(define (annotate! form note!)
|
||||||
|
(cond ((and (list? form)
|
||||||
|
(< 2 (length form))
|
||||||
|
(eq? 'define (car form))
|
||||||
|
(pair? (cadr form))
|
||||||
|
(symbol? (caadr form)))
|
||||||
|
(note! ':type 'procedure)
|
||||||
|
(note! ':signature (cadr form))
|
||||||
|
(and (< 3 (length form))
|
||||||
|
(string? (caddr form))
|
||||||
|
(note! ':std-int-doc (caddr form))))
|
||||||
|
((and (list? form)
|
||||||
|
(< 2 (length form))
|
||||||
|
(eq? 'define (car form))
|
||||||
|
(symbol? (cadr form))
|
||||||
|
(list? (caddr form))
|
||||||
|
(< 3 (length (caddr form)))
|
||||||
|
(eq? 'lambda (car (caddr form)))
|
||||||
|
(string? (caddr (caddr form))))
|
||||||
|
(note! ':type 'procedure)
|
||||||
|
(note! ':signature (cons (cadr form) (cadr (caddr form))))
|
||||||
|
(note! ':std-int-doc (caddr (caddr form))))
|
||||||
|
((and (list? form)
|
||||||
|
(= 3 (length form))
|
||||||
|
(eq? 'define (car form))
|
||||||
|
(symbol? (cadr form))
|
||||||
|
(symbol? (caddr form)))
|
||||||
|
(note! ':type 'alias))
|
||||||
|
((and (list? form)
|
||||||
|
(eq? 'define-module (car form)))
|
||||||
|
(note! ':type 'define-module))
|
||||||
|
;; Add other types here.
|
||||||
|
(else (note! ':type 'variable))))
|
||||||
|
|
||||||
|
;; Process FILE, calling NB! on parsed top-level elements.
|
||||||
|
;; Recognized: #!-!# and regular comments in addition to normal forms.
|
||||||
|
;;
|
||||||
|
(define (process file nb!)
|
||||||
|
(nb! `'(filename ,file))
|
||||||
|
(let ((hash-bang-rx (make-regexp "^#!"))
|
||||||
|
(bang-hash-rx (make-regexp "^!#"))
|
||||||
|
(all-comment-rx (make-regexp "^[ \t]*(;+)"))
|
||||||
|
(all-whitespace-rx (make-regexp "^[ \t]*$"))
|
||||||
|
(p (open-input-file file)))
|
||||||
|
(let loop ((n (1+ (port-line p))) (line (read-line p)))
|
||||||
|
(or (not n)
|
||||||
|
(eof-object? line)
|
||||||
|
(begin
|
||||||
|
(cond ((regexp-exec hash-bang-rx line)
|
||||||
|
(let loop ((line (read-line p))
|
||||||
|
(text (list line)))
|
||||||
|
(if (or (eof-object? line)
|
||||||
|
(regexp-exec bang-hash-rx line))
|
||||||
|
(nb! `'(hash-bang-comment
|
||||||
|
:line ,n
|
||||||
|
:line-count ,(1+ (length text))
|
||||||
|
:text-list ,(reverse
|
||||||
|
(cons line text))))
|
||||||
|
(loop (read-line p)
|
||||||
|
(cons line text)))))
|
||||||
|
((regexp-exec all-whitespace-rx line)
|
||||||
|
(nb! `'(whitespace :text ,line)))
|
||||||
|
((regexp-exec all-comment-rx line)
|
||||||
|
=> (lambda (m)
|
||||||
|
(nb! `'(comment
|
||||||
|
:leading-semicolons
|
||||||
|
,(let ((m1 (vector-ref m 1)))
|
||||||
|
(- (cdr m1) (car m1)))
|
||||||
|
:text ,line))))
|
||||||
|
(else
|
||||||
|
(unread-string line p)
|
||||||
|
(let* ((form (read p))
|
||||||
|
(count (- (port-line p) n))
|
||||||
|
(props (let* ((props '())
|
||||||
|
(prop+ (lambda args
|
||||||
|
(set! props
|
||||||
|
(append props args)))))
|
||||||
|
(annotate! form prop+)
|
||||||
|
props)))
|
||||||
|
(or (= count 1) ; ugh
|
||||||
|
(begin
|
||||||
|
(read-line p)
|
||||||
|
(set! count (1+ count))))
|
||||||
|
(nb! `'(following-form-properties
|
||||||
|
:line ,n
|
||||||
|
:line-count ,count
|
||||||
|
,@props))
|
||||||
|
(nb! form))))
|
||||||
|
(loop (1+ (port-line p)) (read-line p)))))))
|
||||||
|
|
||||||
|
;;; entry points
|
||||||
|
|
||||||
|
(define (read-scheme-source-silently . files)
|
||||||
|
"See commentary in module (scripts read-scheme-source)."
|
||||||
|
(let* ((res '()))
|
||||||
|
(for-each (lambda (file)
|
||||||
|
(process file (lambda (e) (set! res (cons e res)))))
|
||||||
|
files)
|
||||||
|
(reverse res)))
|
||||||
|
|
||||||
|
(define (read-scheme-source . files)
|
||||||
|
"See commentary in module (scripts read-scheme-source)."
|
||||||
|
(for-each (lambda (file)
|
||||||
|
(process file (lambda (e) (write e) (newline))))
|
||||||
|
files))
|
||||||
|
|
||||||
|
;; Recognize: (quote (SYM :TAG1 VAL1 :TAG2 VAL2 ...))
|
||||||
|
;; and return alist: ((TAG1 . VAL1) (TAG2 . VAL2) ...)
|
||||||
|
;; where the tags are symbols.
|
||||||
|
;;
|
||||||
|
(define (quoted? sym form)
|
||||||
|
(and (list? form)
|
||||||
|
(= 2 (length form))
|
||||||
|
(eq? 'quote (car form))
|
||||||
|
(let ((inside (cadr form)))
|
||||||
|
(and (list? inside)
|
||||||
|
(< 0 (length inside))
|
||||||
|
(eq? sym (car inside))
|
||||||
|
(let loop ((ls (cdr inside)) (alist '()))
|
||||||
|
(if (null? ls)
|
||||||
|
alist ; retval
|
||||||
|
(let ((first (car ls)))
|
||||||
|
(or (symbol? first)
|
||||||
|
(error "bad list!"))
|
||||||
|
(loop (cddr ls)
|
||||||
|
(acons (string->symbol
|
||||||
|
(substring (symbol->string first) 1))
|
||||||
|
(cadr ls)
|
||||||
|
alist)))))))))
|
||||||
|
|
||||||
|
;; Filter FORMS, combining contiguous comment forms that have the same number
|
||||||
|
;; of leading semicolons. Do not include in them whitespace lines.
|
||||||
|
;; Whitespace lines outside of such comment groupings are ignored, as are
|
||||||
|
;; hash-bang comments. All other forms are passed through unchanged.
|
||||||
|
;;
|
||||||
|
(define (clump forms)
|
||||||
|
(let loop ((forms forms) (acc '()) (pass-this-one-through? #f))
|
||||||
|
(if (null? forms)
|
||||||
|
(reverse acc) ; retval
|
||||||
|
(let ((form (car forms)))
|
||||||
|
(cond (pass-this-one-through?
|
||||||
|
(loop (cdr forms) (cons form acc) #f))
|
||||||
|
((quoted? 'following-form-properties form)
|
||||||
|
(loop (cdr forms) (cons form acc) #t))
|
||||||
|
((quoted? 'whitespace form) ;;; ignore
|
||||||
|
(loop (cdr forms) acc #f))
|
||||||
|
((quoted? 'hash-bang-comment form) ;;; ignore for now
|
||||||
|
(loop (cdr forms) acc #f))
|
||||||
|
((quoted? 'comment form)
|
||||||
|
=> (lambda (alist)
|
||||||
|
(let cloop ((inner-forms (cdr forms))
|
||||||
|
(level (assq-ref alist 'leading-semicolons))
|
||||||
|
(text (list (assq-ref alist 'text))))
|
||||||
|
(let ((up (lambda ()
|
||||||
|
(loop inner-forms
|
||||||
|
(cons (cons level (reverse text))
|
||||||
|
acc)
|
||||||
|
#f))))
|
||||||
|
(if (null? inner-forms)
|
||||||
|
(up)
|
||||||
|
(let ((inner-form (car inner-forms)))
|
||||||
|
(cond ((quoted? 'comment inner-form)
|
||||||
|
=> (lambda (inner-alist)
|
||||||
|
(let ((new-level
|
||||||
|
(assq-ref
|
||||||
|
inner-alist
|
||||||
|
'leading-semicolons)))
|
||||||
|
(if (= new-level level)
|
||||||
|
(cloop (cdr inner-forms)
|
||||||
|
level
|
||||||
|
(cons (assq-ref
|
||||||
|
inner-alist
|
||||||
|
'text)
|
||||||
|
text))
|
||||||
|
(up)))))
|
||||||
|
(else (up)))))))))
|
||||||
|
(else (loop (cdr forms) (cons form acc) #f)))))))
|
||||||
|
|
||||||
|
;;; script entry point
|
||||||
|
|
||||||
|
(define main read-scheme-source)
|
||||||
|
|
||||||
|
;;; read-scheme-source ends here
|
||||||
313
scripts/snarf-check-and-output-texi
Executable file
313
scripts/snarf-check-and-output-texi
Executable file
|
|
@ -0,0 +1,313 @@
|
||||||
|
#!/bin/sh
|
||||||
|
# aside from this initial boilerplate, this is actually -*- scheme -*- code
|
||||||
|
main="(module-ref (resolve-module '(scripts snarf-check-and-output-texi)) 'main)"
|
||||||
|
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
|
||||||
|
!#
|
||||||
|
;;; snarf-check-and-output-texi --- called by the doc snarfer.
|
||||||
|
|
||||||
|
;; Copyright (C) 2001 Free Software Foundation, Inc.
|
||||||
|
;;
|
||||||
|
;; This program is free software; you can redistribute it and/or
|
||||||
|
;; modify it under the terms of the GNU General Public License as
|
||||||
|
;; published by the Free Software Foundation; either version 2, or
|
||||||
|
;; (at your option) any later version.
|
||||||
|
;;
|
||||||
|
;; This program is distributed in the hope that it will be useful,
|
||||||
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||||
|
;; General Public License for more details.
|
||||||
|
;;
|
||||||
|
;; You should have received a copy of the GNU General Public License
|
||||||
|
;; along with this software; see the file COPYING. If not, write to
|
||||||
|
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||||
|
;; Boston, MA 02111-1307 USA
|
||||||
|
|
||||||
|
;;; Author: Michael Livshin
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(define-module (scripts snarf-check-and-output-texi)
|
||||||
|
:use-module (ice-9 streams)
|
||||||
|
:use-module (ice-9 match)
|
||||||
|
:export (snarf-check-and-output-texi))
|
||||||
|
|
||||||
|
;;; why aren't these in some module?
|
||||||
|
|
||||||
|
(define-macro (when cond . body)
|
||||||
|
`(if ,cond (begin ,@body)))
|
||||||
|
|
||||||
|
(define-macro (unless cond . body)
|
||||||
|
`(if (not ,cond) (begin ,@body)))
|
||||||
|
|
||||||
|
(define *manual-flag* #f)
|
||||||
|
|
||||||
|
(define (snarf-check-and-output-texi . flags)
|
||||||
|
(if (member "--manual" flags)
|
||||||
|
(set! *manual-flag* #t))
|
||||||
|
(process-stream (current-input-port)))
|
||||||
|
|
||||||
|
(define (process-stream port)
|
||||||
|
(let loop ((input (stream-map (match-lambda
|
||||||
|
(('id . s)
|
||||||
|
(cons 'id (string->symbol s)))
|
||||||
|
(('int_dec . s)
|
||||||
|
(cons 'int (string->number s)))
|
||||||
|
(('int_oct . s)
|
||||||
|
(cons 'int (string->number s 8)))
|
||||||
|
(('int_hex . s)
|
||||||
|
(cons 'int (string->number s 16)))
|
||||||
|
((and x (? symbol?))
|
||||||
|
(cons x x))
|
||||||
|
((and x (? string?))
|
||||||
|
(cons 'string x))
|
||||||
|
(x x))
|
||||||
|
(make-stream (lambda (s)
|
||||||
|
(let loop ((s s))
|
||||||
|
(cond
|
||||||
|
((stream-null? s) #t)
|
||||||
|
((eq? 'eol (stream-car s))
|
||||||
|
(loop (stream-cdr s)))
|
||||||
|
(else (cons (stream-car s) (stream-cdr s))))))
|
||||||
|
(port->stream port read)))))
|
||||||
|
|
||||||
|
(unless (stream-null? input)
|
||||||
|
(let ((token (stream-car input)))
|
||||||
|
(if (eq? (car token) 'snarf_cookie)
|
||||||
|
(dispatch-top-cookie (stream-cdr input)
|
||||||
|
loop)
|
||||||
|
(loop (stream-cdr input)))))))
|
||||||
|
|
||||||
|
(define (dispatch-top-cookie input cont)
|
||||||
|
|
||||||
|
(when (stream-null? input)
|
||||||
|
(error 'syntax "premature end of file"))
|
||||||
|
|
||||||
|
(let ((token (stream-car input)))
|
||||||
|
(cond
|
||||||
|
((eq? (car token) 'brace_open)
|
||||||
|
(consume-multiline (stream-cdr input)
|
||||||
|
cont))
|
||||||
|
(else
|
||||||
|
(consume-upto-cookie process-singleline
|
||||||
|
input
|
||||||
|
cont)))))
|
||||||
|
|
||||||
|
(define (consume-upto-cookie process input cont)
|
||||||
|
(let loop ((acc '()) (input input))
|
||||||
|
|
||||||
|
(when (stream-null? input)
|
||||||
|
(error 'syntax "premature end of file in directive context"))
|
||||||
|
|
||||||
|
(let ((token (stream-car input)))
|
||||||
|
(cond
|
||||||
|
((eq? (car token) 'snarf_cookie)
|
||||||
|
(process (reverse! acc))
|
||||||
|
(cont (stream-cdr input)))
|
||||||
|
|
||||||
|
(else (loop (cons token acc) (stream-cdr input)))))))
|
||||||
|
|
||||||
|
(define (consume-multiline input cont)
|
||||||
|
(begin-multiline)
|
||||||
|
|
||||||
|
(let loop ((input input))
|
||||||
|
|
||||||
|
(when (stream-null? input)
|
||||||
|
(error 'syntax "premature end of file in multiline context"))
|
||||||
|
|
||||||
|
(let ((token (stream-car input)))
|
||||||
|
(cond
|
||||||
|
((eq? (car token) 'brace_close)
|
||||||
|
(end-multiline)
|
||||||
|
(cont (stream-cdr input)))
|
||||||
|
|
||||||
|
(else (consume-upto-cookie process-multiline-directive
|
||||||
|
input
|
||||||
|
loop))))))
|
||||||
|
|
||||||
|
(define *file* #f)
|
||||||
|
(define *line* #f)
|
||||||
|
(define *c-function-name* #f)
|
||||||
|
(define *function-name* #f)
|
||||||
|
(define *snarf-type* #f)
|
||||||
|
(define *args* #f)
|
||||||
|
(define *sig* #f)
|
||||||
|
(define *docstring* #f)
|
||||||
|
|
||||||
|
(define (begin-multiline)
|
||||||
|
(set! *file* #f)
|
||||||
|
(set! *line* #f)
|
||||||
|
(set! *c-function-name* #f)
|
||||||
|
(set! *function-name* #f)
|
||||||
|
(set! *snarf-type* #f)
|
||||||
|
(set! *args* #f)
|
||||||
|
(set! *sig* #f)
|
||||||
|
(set! *docstring* #f))
|
||||||
|
|
||||||
|
(define *primitive-deffnx-signature* "@deffnx {Scheme Procedure} ")
|
||||||
|
(define *primitive-deffnx-sig-length* (string-length *primitive-deffnx-signature*))
|
||||||
|
|
||||||
|
(define (end-multiline)
|
||||||
|
(let* ((req (car *sig*))
|
||||||
|
(opt (cadr *sig*))
|
||||||
|
(var (caddr *sig*))
|
||||||
|
(all (+ req opt var)))
|
||||||
|
(if (and (not (eqv? *snarf-type* 'register))
|
||||||
|
(not (= (length *args*) all)))
|
||||||
|
(error (format #f "~A:~A: ~A's C implementation takes ~A args (should take ~A)"
|
||||||
|
*file* *line* name (length *args*) all)))
|
||||||
|
(let ((nice-sig
|
||||||
|
(if (eq? *snarf-type* 'register)
|
||||||
|
*function-name*
|
||||||
|
(with-output-to-string
|
||||||
|
(lambda ()
|
||||||
|
(format #t "~A" *function-name*)
|
||||||
|
(let loop-req ((args *args*) (r 0))
|
||||||
|
(if (< r req)
|
||||||
|
(begin
|
||||||
|
(format #t " ~A" (car args))
|
||||||
|
(loop-req (cdr args) (+ 1 r)))
|
||||||
|
(let loop-opt ((o 0) (args args) (tail '()))
|
||||||
|
(if (< o opt)
|
||||||
|
(begin
|
||||||
|
(format #t " [~A" (car args))
|
||||||
|
(loop-opt (+ 1 o) (cdr args) (cons #\] tail)))
|
||||||
|
(begin
|
||||||
|
(if (> var 0)
|
||||||
|
(format #t " . ~A"
|
||||||
|
(car args)))
|
||||||
|
(let loop-tail ((tail tail))
|
||||||
|
(if (not (null? tail))
|
||||||
|
(begin
|
||||||
|
(format #t "~A" (car tail))
|
||||||
|
(loop-tail (cdr tail))))))))))))))
|
||||||
|
(scm-deffnx
|
||||||
|
(if (and *manual-flag* (eq? *snarf-type* 'primitive))
|
||||||
|
(with-output-to-string
|
||||||
|
(lambda ()
|
||||||
|
(format #t "@deffnx {C Function} ~A (" *c-function-name*)
|
||||||
|
(unless (null? *args*)
|
||||||
|
(format #t "~A" (car *args*))
|
||||||
|
(let loop ((args (cdr *args*)))
|
||||||
|
(unless (null? args)
|
||||||
|
(format #t ", ~A" (car args))
|
||||||
|
(loop (cdr args)))))
|
||||||
|
(format #t ")\n")))
|
||||||
|
#f)))
|
||||||
|
(format #t "\n ~A\n" *function-name*)
|
||||||
|
(format #t "@c snarfed from ~A:~A\n" *file* *line*)
|
||||||
|
(format #t "@deffn {Scheme Procedure} ~A\n" nice-sig)
|
||||||
|
(let loop ((strings *docstring*) (scm-deffnx scm-deffnx))
|
||||||
|
(cond ((null? strings))
|
||||||
|
((or (not scm-deffnx)
|
||||||
|
(and (>= (string-length (car strings))
|
||||||
|
*primitive-deffnx-sig-length*)
|
||||||
|
(string=? (substring (car strings)
|
||||||
|
0 *primitive-deffnx-sig-length*)
|
||||||
|
*primitive-deffnx-signature*)))
|
||||||
|
(display (car strings))
|
||||||
|
(loop (cdr strings) scm-deffnx))
|
||||||
|
(else (display scm-deffnx)
|
||||||
|
(loop strings #f))))
|
||||||
|
(display "\n")
|
||||||
|
(display "@end deffn\n"))))
|
||||||
|
|
||||||
|
(define (texi-quote s)
|
||||||
|
(let rec ((i 0))
|
||||||
|
(if (= i (string-length s))
|
||||||
|
""
|
||||||
|
(string-append (let ((ss (substring s i (+ i 1))))
|
||||||
|
(if (string=? ss "@")
|
||||||
|
"@@"
|
||||||
|
ss))
|
||||||
|
(rec (+ i 1))))))
|
||||||
|
|
||||||
|
(define (process-multiline-directive l)
|
||||||
|
|
||||||
|
(define do-args
|
||||||
|
(match-lambda
|
||||||
|
|
||||||
|
(('(paren_close . paren_close))
|
||||||
|
'())
|
||||||
|
|
||||||
|
(('(comma . comma) rest ...)
|
||||||
|
(do-args rest))
|
||||||
|
|
||||||
|
(('(id . SCM) ('id . name) rest ...)
|
||||||
|
(cons name (do-args rest)))
|
||||||
|
|
||||||
|
(x (error (format #f "invalid argument syntax: ~A" (map cdr x))))))
|
||||||
|
|
||||||
|
(define do-arglist
|
||||||
|
(match-lambda
|
||||||
|
|
||||||
|
(('(paren_open . paren_open) '(id . void) '(paren_close . paren_close))
|
||||||
|
'())
|
||||||
|
|
||||||
|
(('(paren_open . paren_open) rest ...)
|
||||||
|
(do-args rest))
|
||||||
|
|
||||||
|
(x (error (format #f "invalid arglist syntax: ~A" (map cdr x))))))
|
||||||
|
|
||||||
|
(define do-command
|
||||||
|
(match-lambda
|
||||||
|
|
||||||
|
(('cname ('id . name))
|
||||||
|
(set! *c-function-name* (texi-quote (symbol->string name))))
|
||||||
|
|
||||||
|
(('fname ('string . name))
|
||||||
|
(set! *function-name* (texi-quote name)))
|
||||||
|
|
||||||
|
(('type ('id . type))
|
||||||
|
(set! *snarf-type* type))
|
||||||
|
|
||||||
|
(('type ('int . num))
|
||||||
|
(set! *snarf-type* num))
|
||||||
|
|
||||||
|
(('location ('string . file) ('int . line))
|
||||||
|
(set! *file* file)
|
||||||
|
(set! *line* line))
|
||||||
|
|
||||||
|
(('arglist rest ...)
|
||||||
|
(set! *args* (do-arglist rest)))
|
||||||
|
|
||||||
|
(('argsig ('int . req) ('int . opt) ('int . var))
|
||||||
|
(set! *sig* (list req opt var)))
|
||||||
|
|
||||||
|
(x (error (format #f "unknown doc attribute: ~A" x)))))
|
||||||
|
|
||||||
|
(define do-directive
|
||||||
|
(match-lambda
|
||||||
|
|
||||||
|
((('id . command) rest ...)
|
||||||
|
(do-command (cons command rest)))
|
||||||
|
|
||||||
|
((('string . string) ...)
|
||||||
|
(set! *docstring* string))
|
||||||
|
|
||||||
|
(x (error (format #f "unknown doc attribute syntax: ~A" x)))))
|
||||||
|
|
||||||
|
(do-directive l))
|
||||||
|
|
||||||
|
(define (process-singleline l)
|
||||||
|
|
||||||
|
(define do-argpos
|
||||||
|
(match-lambda
|
||||||
|
((('id . name) ('int . pos) ('int . line))
|
||||||
|
(let ((idx (list-index *args* name)))
|
||||||
|
(when idx
|
||||||
|
(unless (= (+ idx 1) pos)
|
||||||
|
(display (format #f "~A:~A: wrong position for argument ~A: ~A (should be ~A)\n"
|
||||||
|
*file* line name pos (+ idx 1))
|
||||||
|
(current-error-port))))))
|
||||||
|
(x #f)))
|
||||||
|
|
||||||
|
(define do-command
|
||||||
|
(match-lambda
|
||||||
|
(('(id . argpos) rest ...)
|
||||||
|
(do-argpos rest))
|
||||||
|
(x (error (format #f "unknown check: ~A" x)))))
|
||||||
|
|
||||||
|
(when *function-name*
|
||||||
|
(do-command l)))
|
||||||
|
|
||||||
|
(define main snarf-check-and-output-texi)
|
||||||
88
scripts/snarf-guile-m4-docs
Executable file
88
scripts/snarf-guile-m4-docs
Executable file
|
|
@ -0,0 +1,88 @@
|
||||||
|
#!/bin/sh
|
||||||
|
# aside from this initial boilerplate, this is actually -*- scheme -*- code
|
||||||
|
main='(module-ref (resolve-module '\''(scripts snarf-guile-m4-docs)) '\'main')'
|
||||||
|
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
|
||||||
|
!#
|
||||||
|
;;; snarf-guile-m4-docs --- Parse guile.m4 comments for texi documentation
|
||||||
|
|
||||||
|
;; Copyright (C) 2002 Free Software Foundation, Inc.
|
||||||
|
;;
|
||||||
|
;; This program is free software; you can redistribute it and/or
|
||||||
|
;; modify it under the terms of the GNU General Public License as
|
||||||
|
;; published by the Free Software Foundation; either version 2, or
|
||||||
|
;; (at your option) any later version.
|
||||||
|
;;
|
||||||
|
;; This program is distributed in the hope that it will be useful,
|
||||||
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||||
|
;; General Public License for more details.
|
||||||
|
;;
|
||||||
|
;; You should have received a copy of the GNU General Public License
|
||||||
|
;; along with this software; see the file COPYING. If not, write to
|
||||||
|
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||||
|
;; Boston, MA 02111-1307 USA
|
||||||
|
|
||||||
|
;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;; Usage: snarf-guile-m4-docs FILE
|
||||||
|
;;
|
||||||
|
;; Grep FILE for comments preceding macro definitions, massage
|
||||||
|
;; them into valid texi, and display to stdout. For each comment,
|
||||||
|
;; lines preceding "^# Usage:" are discarded.
|
||||||
|
;;
|
||||||
|
;; TODO: Generalize.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(define-module (scripts snarf-guile-m4-docs)
|
||||||
|
:use-module (ice-9 rdelim)
|
||||||
|
:export (snarf-guile-m4-docs))
|
||||||
|
|
||||||
|
(define (display-texi lines)
|
||||||
|
(display "@deffn {Autoconf Macro}")
|
||||||
|
(for-each (lambda (line)
|
||||||
|
(display (cond ((and (>= (string-length line) 2)
|
||||||
|
(string=? "# " (substring line 0 2)))
|
||||||
|
(substring line 2))
|
||||||
|
((string=? "#" (substring line 0 1))
|
||||||
|
(substring line 1))
|
||||||
|
(else line)))
|
||||||
|
(newline))
|
||||||
|
lines)
|
||||||
|
(display "@end deffn")
|
||||||
|
(newline) (newline))
|
||||||
|
|
||||||
|
(define (prefix? line sub)
|
||||||
|
(false-if-exception
|
||||||
|
(string=? sub (substring line 0 (string-length sub)))))
|
||||||
|
|
||||||
|
(define (massage-usage line)
|
||||||
|
(let loop ((line (string->list line)) (acc '()))
|
||||||
|
(if (null? line)
|
||||||
|
(list (list->string (reverse acc)))
|
||||||
|
(loop (cdr line)
|
||||||
|
(cons (case (car line)
|
||||||
|
((#\( #\) #\,) #\space)
|
||||||
|
(else (car line)))
|
||||||
|
acc)))))
|
||||||
|
|
||||||
|
(define (snarf-guile-m4-docs . args)
|
||||||
|
(let* ((p (open-file (car args) "r"))
|
||||||
|
(next (lambda () (read-line p))))
|
||||||
|
(let loop ((line (next)) (acc #f))
|
||||||
|
(or (eof-object? line)
|
||||||
|
(cond ((prefix? line "# Usage:")
|
||||||
|
(loop (next) (massage-usage (substring line 8))))
|
||||||
|
((prefix? line "AC_DEFUN")
|
||||||
|
(display-texi (reverse acc))
|
||||||
|
(loop (next) #f))
|
||||||
|
((and acc (prefix? line "#"))
|
||||||
|
(loop (next) (cons line acc)))
|
||||||
|
(else
|
||||||
|
(loop (next) #f)))))))
|
||||||
|
|
||||||
|
(define main snarf-guile-m4-docs)
|
||||||
|
|
||||||
|
;;; snarf-guile-m4-docs ends here
|
||||||
113
scripts/use2dot
Executable file
113
scripts/use2dot
Executable file
|
|
@ -0,0 +1,113 @@
|
||||||
|
#!/bin/sh
|
||||||
|
# aside from this initial boilerplate, this is actually -*- scheme -*- code
|
||||||
|
main='(module-ref (resolve-module '\''(scripts use2dot)) '\'main')'
|
||||||
|
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
|
||||||
|
!#
|
||||||
|
;;; use2dot --- Display module dependencies as a DOT specification
|
||||||
|
|
||||||
|
;; Copyright (C) 2001 Free Software Foundation, Inc.
|
||||||
|
;;
|
||||||
|
;; This program is free software; you can redistribute it and/or
|
||||||
|
;; modify it under the terms of the GNU General Public License as
|
||||||
|
;; published by the Free Software Foundation; either version 2, or
|
||||||
|
;; (at your option) any later version.
|
||||||
|
;;
|
||||||
|
;; This program is distributed in the hope that it will be useful,
|
||||||
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||||
|
;; General Public License for more details.
|
||||||
|
;;
|
||||||
|
;; You should have received a copy of the GNU General Public License
|
||||||
|
;; along with this software; see the file COPYING. If not, write to
|
||||||
|
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||||
|
;; Boston, MA 02111-1307 USA
|
||||||
|
|
||||||
|
;;; Author: Thien-Thi Nguyen
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;; Usage: use2dot [OPTIONS] [FILE ...]
|
||||||
|
;; Display to stdout a DOT specification that describes module dependencies
|
||||||
|
;; in FILEs.
|
||||||
|
;;
|
||||||
|
;; A top-level `use-modules' form or a `:use-module' `define-module'-component
|
||||||
|
;; results in a "solid" style edge.
|
||||||
|
;;
|
||||||
|
;; An `:autoload' `define-module'-component results in a "dotted" style edge
|
||||||
|
;; with label "N" indicating that N names are responsible for triggering the
|
||||||
|
;; autoload. [The "N" label is not implemented.]
|
||||||
|
;;
|
||||||
|
;; A top-level `load' or `primitive-load' form results in a a "bold" style
|
||||||
|
;; edge to a node named with either the file name if the `load' argument is a
|
||||||
|
;; string, or "[computed in FILE]" otherwise.
|
||||||
|
;;
|
||||||
|
;; Options:
|
||||||
|
;; -m, --default-module MOD -- Set MOD as the default module (for top-level
|
||||||
|
;; `use-modules' forms that do not follow some
|
||||||
|
;; `define-module' form in a file). MOD should be
|
||||||
|
;; be a list or `#f', in which case such top-level
|
||||||
|
;; `use-modules' forms are effectively ignored.
|
||||||
|
;; Default value: `(guile-user)'.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(define-module (scripts use2dot)
|
||||||
|
:autoload (ice-9 getopt-long) (getopt-long)
|
||||||
|
:use-module ((srfi srfi-13) :select (string-join))
|
||||||
|
:use-module ((scripts frisk)
|
||||||
|
:select (make-frisker edge-type edge-up edge-down))
|
||||||
|
:export (use2dot))
|
||||||
|
|
||||||
|
(define *default-module* '(guile-user))
|
||||||
|
|
||||||
|
(define (q s) ; quote
|
||||||
|
(format #f "~S" s))
|
||||||
|
|
||||||
|
(define (vv pairs) ; => ("var=val" ...)
|
||||||
|
(map (lambda (pair)
|
||||||
|
(format #f "~A=~A" (car pair) (cdr pair)))
|
||||||
|
pairs))
|
||||||
|
|
||||||
|
(define (>>header)
|
||||||
|
(format #t "digraph use2dot {\n")
|
||||||
|
(for-each (lambda (s) (format #t " ~A;\n" s))
|
||||||
|
(vv `((label . ,(q "Guile Module Dependencies"))
|
||||||
|
;;(rankdir . LR)
|
||||||
|
;;(size . ,(q "7.5,10"))
|
||||||
|
(ratio . fill)
|
||||||
|
;;(nodesep . ,(q "0.05"))
|
||||||
|
))))
|
||||||
|
|
||||||
|
(define (>>body edges)
|
||||||
|
(for-each
|
||||||
|
(lambda (edge)
|
||||||
|
(format #t " \"~A\" -> \"~A\"" (edge-down edge) (edge-up edge))
|
||||||
|
(cond ((case (edge-type edge)
|
||||||
|
((autoload) '((style . dotted) (fontsize . 5)))
|
||||||
|
((computed) '((style . bold)))
|
||||||
|
(else #f))
|
||||||
|
=> (lambda (etc)
|
||||||
|
(format #t " [~A]" (string-join (vv etc) ",")))))
|
||||||
|
(format #t ";\n"))
|
||||||
|
edges))
|
||||||
|
|
||||||
|
(define (>>footer)
|
||||||
|
(format #t "}"))
|
||||||
|
|
||||||
|
(define (>> edges)
|
||||||
|
(>>header)
|
||||||
|
(>>body edges)
|
||||||
|
(>>footer))
|
||||||
|
|
||||||
|
(define (use2dot . args)
|
||||||
|
(let* ((parsed-args (getopt-long (cons "use2dot" args) ;;; kludge
|
||||||
|
'((default-module
|
||||||
|
(single-char #\m) (value #t)))))
|
||||||
|
(=m (option-ref parsed-args 'default-module *default-module*))
|
||||||
|
(scan (make-frisker `(default-module . ,=m)))
|
||||||
|
(files (option-ref parsed-args '() '())))
|
||||||
|
(>> (reverse ((scan files) 'edges)))))
|
||||||
|
|
||||||
|
(define main use2dot)
|
||||||
|
|
||||||
|
;;; use2dot ends here
|
||||||
Loading…
Add table
Add a link
Reference in a new issue