mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-18 01:30:27 +02:00
*** empty log message ***
This commit is contained in:
Rob Browning
parent
a3a173b01a
commit
440333c865
17 changed files with 0 additions and 2816 deletions
|
|
@ -1,2 +0,0 @@
|
||||||
Makefile
|
|
||||||
Makefile.in
|
|
||||||
|
|
@ -1,167 +0,0 @@
|
||||||
2002-04-02 Thien-Thi Nguyen <ttn@giblet.glug.org>
|
|
||||||
|
|
||||||
* PROGRAM: Update copyright; nfc.
|
|
||||||
|
|
||||||
2002-03-24 Neil Jerram <neil@ossau.uklinux.net>
|
|
||||||
|
|
||||||
* snarf-guile-m4-docs (display-texi): Strip off `# ' from start of
|
|
||||||
docstring lines if possible, rather than just `#'.
|
|
||||||
|
|
||||||
2002-03-14 Neil Jerram <neil@ossau.uklinux.net>
|
|
||||||
|
|
||||||
These changes add a @deffnx C function declaration and function
|
|
||||||
index entries for each Guile primitive to the copy of the doc
|
|
||||||
snarf output that is used for reference manual synchronization.
|
|
||||||
|
|
||||||
* snarf-check-and-output-texi (*manual-flag*,
|
|
||||||
snarf-check-and-output-texi): Handle `--manual' invocation arg
|
|
||||||
passed through from libguile/Makefile.am.
|
|
||||||
(*c-function-name*, begin-multiline, do-command): Pick out C
|
|
||||||
function name from snarfed token stream.
|
|
||||||
(end-multiline): Add @deffnx C declaration to output.
|
|
||||||
(*primitive-deffnx-signature*, *primitive-deffnx-sig-length*):
|
|
||||||
Fluff to help insert the C declaration after any "@deffnx
|
|
||||||
{Scheme Procedure}" lines in the snarfed docstring.
|
|
||||||
|
|
||||||
* snarf-check-and-output-texi: Change generated @deffn categories
|
|
||||||
from "primitive" to "Scheme Procedure".
|
|
||||||
|
|
||||||
2002-03-05 Neil Jerram <neil@ossau.uklinux.net>
|
|
||||||
|
|
||||||
* Makefile.am (scripts_sources): Add `lint'.
|
|
||||||
|
|
||||||
* lint: New script.
|
|
||||||
|
|
||||||
* frisk (grok-proc): Handle `#:xxx' as well as `:xxx'.
|
|
||||||
|
|
||||||
2002-03-04 Rob Browning <rlb@defaultvalue.org>
|
|
||||||
|
|
||||||
* Makefile.am (scripts_sources): add snarf-guile-m4-docs.
|
|
||||||
|
|
||||||
2002-02-26 Thien-Thi Nguyen <ttn@giblet.glug.org>
|
|
||||||
|
|
||||||
* Makefile.am: Update path to pre-inst-guile automake frag.
|
|
||||||
|
|
||||||
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-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-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
|
|
||||||
|
|
||||||
|
|
@ -1,63 +0,0 @@
|
||||||
## Process this file with automake to produce Makefile.in.
|
|
||||||
##
|
|
||||||
## Copyright (C) 2001 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 \
|
|
||||||
use2dot \
|
|
||||||
snarf-check-and-output-texi \
|
|
||||||
snarf-guile-m4-docs
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
@ -1,45 +0,0 @@
|
||||||
#!/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
|
|
||||||
|
|
@ -1,76 +0,0 @@
|
||||||
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]
|
|
||||||
|
|
@ -1,86 +0,0 @@
|
||||||
#!/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 alist-file-A alist-file-B
|
|
||||||
;; Read in the alists from files ALIST-FILE-A and ALIST-FILE-B
|
|
||||||
;; and display four lists: old scheme, new scheme, old C, new C.
|
|
||||||
;;
|
|
||||||
;; For scheme programming, the (scripts api-diff) module exports
|
|
||||||
;; two procedures:
|
|
||||||
;; (diff-alists A-alist B-alist report)
|
|
||||||
;; (api-diff A-file B-file)
|
|
||||||
;; The latter implements the shell interface using the former.
|
|
||||||
;; REPORT is a proc that takes the above four lists. Its return
|
|
||||||
;; value is returned by `diff-alists'.
|
|
||||||
;;
|
|
||||||
;; Note that the convention is that the "older" alist/file is
|
|
||||||
;; specified first.
|
|
||||||
;;
|
|
||||||
;; TODO: When the annotations support it, also detect/report
|
|
||||||
;; procedure signature, or other simple type, changes.
|
|
||||||
|
|
||||||
;;; Code:
|
|
||||||
|
|
||||||
(define-module (scripts api-diff)
|
|
||||||
:use-module (ice-9 common-list)
|
|
||||||
:export (diff-alists api-diff))
|
|
||||||
|
|
||||||
(define (read-alist-file file)
|
|
||||||
(with-input-from-file file
|
|
||||||
(lambda () (read))))
|
|
||||||
|
|
||||||
(define (diff x y) (set-difference (map car x) (map car y)))
|
|
||||||
|
|
||||||
(define (diff-alists A B report)
|
|
||||||
(let* ((A-scheme (assq-ref A 'scheme))
|
|
||||||
(A-C (assq-ref A 'C))
|
|
||||||
(B-scheme (assq-ref B 'scheme))
|
|
||||||
(B-C (assq-ref B 'C))
|
|
||||||
(OLD-scheme (diff A-scheme B-scheme))
|
|
||||||
(NEW-scheme (diff B-scheme A-scheme))
|
|
||||||
(OLD-C (diff A-C B-C))
|
|
||||||
(NEW-C (diff B-C A-C)))
|
|
||||||
(report OLD-scheme NEW-scheme OLD-C NEW-C)))
|
|
||||||
|
|
||||||
(define (display-list head ls)
|
|
||||||
(format #t ":: ~A -- ~A\n" head (length ls))
|
|
||||||
(for-each (lambda (x) (format #t "~A\n" x)) ls)
|
|
||||||
(newline))
|
|
||||||
|
|
||||||
(define (api-diff . args)
|
|
||||||
(diff-alists (read-alist-file (list-ref args 0))
|
|
||||||
(read-alist-file (list-ref args 1))
|
|
||||||
(lambda (OLD-scheme NEW-scheme OLD-C NEW-C)
|
|
||||||
(display-list "OLD (deleted) scheme" OLD-scheme)
|
|
||||||
(display-list "NEW scheme" NEW-scheme)
|
|
||||||
(display-list "OLD (deleted) C" OLD-C)
|
|
||||||
(display-list "NEW C" NEW-C))))
|
|
||||||
|
|
||||||
(define main api-diff)
|
|
||||||
|
|
||||||
;;; api-diff ends here
|
|
||||||
|
|
@ -1,221 +0,0 @@
|
||||||
#!/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
|
|
||||||
|
|
@ -1,70 +0,0 @@
|
||||||
#!/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
|
|
||||||
|
|
@ -1,442 +0,0 @@
|
||||||
#!/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
292
scripts/frisk
|
|
@ -1,292 +0,0 @@
|
||||||
#!/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 #:use-module)
|
|
||||||
(note-use! 'regular module (ferret (cadr ls)))
|
|
||||||
(loop (cddr ls)))
|
|
||||||
((:autoload #:autoload)
|
|
||||||
(note-use! 'autoload module (cadr ls))
|
|
||||||
(loop (cdddr ls)))
|
|
||||||
(else (loop (cdr ls))))))))
|
|
||||||
((use-modules)
|
|
||||||
(for-each (lambda (use)
|
|
||||||
(note-use! 'regular
|
|
||||||
(or curmod default-module)
|
|
||||||
(ferret use)))
|
|
||||||
(cdr form)))
|
|
||||||
((load primitive-load)
|
|
||||||
(note-use! 'computed
|
|
||||||
(or curmod default-module)
|
|
||||||
(let ((file (cadr form)))
|
|
||||||
(if (string? file)
|
|
||||||
file
|
|
||||||
(format #f "[computed in ~A]"
|
|
||||||
filename))))))
|
|
||||||
(loop (next))))))))
|
|
||||||
|
|
||||||
(define up-ls (make-object-property)) ; list
|
|
||||||
(define dn-ls (make-object-property)) ; list
|
|
||||||
(define int? (make-object-property)) ; defined via `define-module'
|
|
||||||
|
|
||||||
(define mod-up-ls up-ls)
|
|
||||||
(define mod-down-ls dn-ls)
|
|
||||||
(define mod-int? int?)
|
|
||||||
|
|
||||||
(define (i-or-x module)
|
|
||||||
(if (int? module) 'i 'x))
|
|
||||||
|
|
||||||
(define edge-type (make-object-property)) ; symbol
|
|
||||||
|
|
||||||
(define (make-edge type up down)
|
|
||||||
(let ((new (cons up down)))
|
|
||||||
(set! (edge-type new) type)
|
|
||||||
new))
|
|
||||||
|
|
||||||
(define edge-up car)
|
|
||||||
(define edge-down cdr)
|
|
||||||
|
|
||||||
(define (up-ls+! m new) (set! (up-ls m) (cons new (up-ls m))))
|
|
||||||
(define (dn-ls+! m new) (set! (dn-ls m) (cons new (dn-ls m))))
|
|
||||||
|
|
||||||
(define (make-body alist)
|
|
||||||
(lambda (key)
|
|
||||||
(assq-ref alist key)))
|
|
||||||
|
|
||||||
(define (scan default-module files)
|
|
||||||
(let* ((modules (list))
|
|
||||||
(edges (list))
|
|
||||||
(intern (lambda (module)
|
|
||||||
(cond ((member module modules) => car)
|
|
||||||
(else (set! (up-ls module) (list))
|
|
||||||
(set! (dn-ls module) (list))
|
|
||||||
(set! modules (cons module modules))
|
|
||||||
module))))
|
|
||||||
(grok (grok-proc default-module
|
|
||||||
(lambda (type d u)
|
|
||||||
(let ((d (intern d)))
|
|
||||||
(if (eq? type 'def)
|
|
||||||
(set! (int? d) #t)
|
|
||||||
(let* ((u (intern u))
|
|
||||||
(edge (make-edge type u d)))
|
|
||||||
(set! edges (cons edge edges))
|
|
||||||
(up-ls+! d edge)
|
|
||||||
(dn-ls+! u edge))))))))
|
|
||||||
(for-each grok files)
|
|
||||||
(make-body
|
|
||||||
`((modules . ,modules)
|
|
||||||
(internal . ,(filter int? modules))
|
|
||||||
(external . ,(remove int? modules))
|
|
||||||
(i-up . ,(filter int? (map edge-down edges)))
|
|
||||||
(x-up . ,(remove int? (map edge-down edges)))
|
|
||||||
(i-down . ,(filter int? (map edge-up edges)))
|
|
||||||
(x-down . ,(remove int? (map edge-up edges)))
|
|
||||||
(edges . ,edges)))))
|
|
||||||
|
|
||||||
(define (make-frisker . options)
|
|
||||||
(let ((default-module (or (assq-ref options 'default-module)
|
|
||||||
*default-module*)))
|
|
||||||
(lambda (files)
|
|
||||||
(scan default-module files))))
|
|
||||||
|
|
||||||
(define (dump-updown modules)
|
|
||||||
(for-each (lambda (m)
|
|
||||||
(format #t "~A ~A --- ~A --- ~A\n"
|
|
||||||
(i-or-x m) m
|
|
||||||
(map (lambda (edge)
|
|
||||||
(cons (edge-type edge)
|
|
||||||
(edge-up edge)))
|
|
||||||
(up-ls m))
|
|
||||||
(map (lambda (edge)
|
|
||||||
(cons (edge-type edge)
|
|
||||||
(edge-down edge)))
|
|
||||||
(dn-ls m))))
|
|
||||||
modules))
|
|
||||||
|
|
||||||
(define (dump-up modules)
|
|
||||||
(for-each (lambda (m)
|
|
||||||
(format #t "~A ~A\n" (i-or-x m) m)
|
|
||||||
(for-each (lambda (edge)
|
|
||||||
(format #t "\t\t\t ~A\t~A\n"
|
|
||||||
(edge-type edge) (edge-up edge)))
|
|
||||||
(up-ls m)))
|
|
||||||
modules))
|
|
||||||
|
|
||||||
(define (dump-down modules)
|
|
||||||
(for-each (lambda (m)
|
|
||||||
(format #t "~A ~A\n" (i-or-x m) m)
|
|
||||||
(for-each (lambda (edge)
|
|
||||||
(format #t "\t\t\t ~A\t~A\n"
|
|
||||||
(edge-type edge) (edge-down edge)))
|
|
||||||
(dn-ls m)))
|
|
||||||
modules))
|
|
||||||
|
|
||||||
(define (frisk . args)
|
|
||||||
(let* ((parsed-opts (getopt-long
|
|
||||||
(cons "frisk" args) ;;; kludge
|
|
||||||
'((upstream (single-char #\u))
|
|
||||||
(downstream (single-char #\d))
|
|
||||||
(internal (single-char #\i))
|
|
||||||
(external (single-char #\x))
|
|
||||||
(default-module
|
|
||||||
(single-char #\m)
|
|
||||||
(value #t)))))
|
|
||||||
(=u (option-ref parsed-opts 'upstream #f))
|
|
||||||
(=d (option-ref parsed-opts 'downstream #f))
|
|
||||||
(=i (option-ref parsed-opts 'internal #f))
|
|
||||||
(=x (option-ref parsed-opts 'external #f))
|
|
||||||
(files (option-ref parsed-opts '() (list)))
|
|
||||||
(report ((make-frisker
|
|
||||||
`(default-module
|
|
||||||
. ,(option-ref parsed-opts 'default-module
|
|
||||||
*default-module*)))
|
|
||||||
files))
|
|
||||||
(modules (report 'modules))
|
|
||||||
(internal (report 'internal))
|
|
||||||
(external (report 'external))
|
|
||||||
(edges (report 'edges)))
|
|
||||||
(format #t "~A ~A, ~A ~A (~A ~A, ~A ~A), ~A ~A\n\n"
|
|
||||||
(length files) "files"
|
|
||||||
(length modules) "modules"
|
|
||||||
(length internal) "internal"
|
|
||||||
(length external) "external"
|
|
||||||
(length edges) "edges")
|
|
||||||
((cond ((and =u =d) dump-updown)
|
|
||||||
(=u dump-up)
|
|
||||||
(else dump-down))
|
|
||||||
(cond ((and =i =x) modules)
|
|
||||||
(=i internal)
|
|
||||||
(else external)))))
|
|
||||||
|
|
||||||
(define main frisk)
|
|
||||||
|
|
||||||
;;; frisk ends here
|
|
||||||
|
|
@ -1,146 +0,0 @@
|
||||||
#!/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
319
scripts/lint
|
|
@ -1,319 +0,0 @@
|
||||||
#!/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
|
|
||||||
|
|
@ -1,89 +0,0 @@
|
||||||
#!/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
|
|
||||||
|
|
@ -1,284 +0,0 @@
|
||||||
#!/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
|
|
||||||
|
|
@ -1,313 +0,0 @@
|
||||||
#!/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)
|
|
||||||
|
|
@ -1,88 +0,0 @@
|
||||||
#!/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
113
scripts/use2dot
|
|
@ -1,113 +0,0 @@
|
||||||
#!/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