mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-15 08:10:17 +02:00
Code Activity

New file

Browse source
This commit is contained in:
Thien-Thi Nguyen 2001-04-30 01:40:32 +00:00
parent d72691f291
commit 28c313422b
9 changed files with 1040 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

5
scripts/ChangeLog Normal file
View file

@ -0,0 +1,5 @@
2001-04-29 Thien-Thi Nguyen <ttn@revel.glug.org>
* Makefile.am, PROGRAM, README, display-commentary,
doc-snarf, generate-autoload, punify, use2dot: New file

40
scripts/Makefile.am Normal file
View file

@ -0,0 +1,40 @@
## 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 = foreign
# These should be installed and distributed.
scripts_sources = \
PROGRAM \
display-commentary \
doc-snarf \
generate-autoload \
punify \
use2dot
subpkgdatadir = $(pkgdatadir)/$(VERSION)/scripts
subpkgdata_SCRIPTS = $(scripts_sources)
EXTRA_DIST = $(scripts_sources)
overview:
@GUILE_LOAD_PATH=`(cd .. ; pwd)` \
./display-commentary $(scripts_sources)

45
scripts/PROGRAM Executable file
View file

@ -0,0 +1,45 @@
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts PROGRAM)) '\'main')'
exec ${GUILE-guile} -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; PROGRAM --- Does something
;; 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
;;; Commentary:
;; Usage: PROGRAM [ARGS]
;;
;; PROGRAM does something.
;;
;; TODO: Write it!
;;
;; Author: J.R.Hacker
;;; Code:
(define-module (scripts PROGRAM)
:export (PROGRAM))
(define (PROGRAM . args)
#t)
(define main PROGRAM)
;;; PROGRAM ends here

76
scripts/README Normal file
View file

@ -0,0 +1,76 @@
Overview and Usage
------------------
This directory contains Scheme programs, some useful in maintaining Guile.
On "make install", these programs are copied to PKGDATADIR/VERSION/scripts.
You can invoke a program from the shell, or alternatively, load its file
as a Guile Scheme module, and use its exported procedure(s) from Scheme code.
Typically for any PROGRAM:
(use-modules (scripts PROGRAM))
(PROGRAM ARG1 ARG2 ...)
For programs that write to stdout, you might try, instead:
(use-modules (scripts PROGRAM))
(with-output-to-string (lambda () (PROGRAM ARG1 ARG2 ...)))
Note that all args must be strings.
To see PROGRAM's commentary, which may or may not be helpful:
(help (scripts PROGRAM))
To see all commentaries and module dependencies, try: "make overview".
If you want to try the programs before installing Guile, you will probably
need to set environment variable GUILE_LOAD_PATH to be the parent directory.
This can be done in Bourne-compatible shells like so:
GUILE_LOAD_PATH=`(cd .. ; pwd)`
export GUILE_LOAD_PATH
[FIXME: Can someone supply the csh-compatible equivalent?]
How to Contribute
-----------------
See template file PROGRAM for a quick start.
Programs must follow the "executable module" convention, documented here:
- The file name must not end in ".scm".
- The file must be executable (chmod +x).
- The module name must be "(scripts PROGRAM)". A procedure named PROGRAM w/
signature "(PROGRAM . args)" must be exported. Basically, use some variant
of the form:
(define-module (scripts PROGRAM)
:export (PROGRAM))
Feel free to export other definitions useful in the module context.
- There must be the alias:
(define main PROGRAM)
However, `main' must NOT be exported.
- The beginning of the file must use the following invocation sequence:
#!/bin/sh
main='(module-ref (resolve-module '\''(scripts PROGRAM)) '\'main')'
exec ${GUILE-guile} -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]

47
scripts/display-commentary Executable file
View file

@ -0,0 +1,47 @@
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts display-commentary)) '\'main')'
exec ${GUILE-guile} -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
;;; Commentary:
;; Usage: display-commentary FILE1 FILE2 ...
;;
;; Display Commentary section from FILE1, FILE2 and so on.
;;
;; Author: Thien-Thi Nguyen
;;; 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 (display-commentary . files)
(for-each display-commentary-one files))
(define main display-commentary)
;;; display-commentary ends here

442
scripts/doc-snarf Executable file
View file

@ -0,0 +1,442 @@
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts doc-snarf)) '\'main')'
exec ${GUILE-guile} -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
;;; 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
;;; Author: Martin Grabmueller
(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

138
scripts/generate-autoload Executable file
View file

@ -0,0 +1,138 @@
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts generate-autoload)) '\'main')'
exec ${GUILE-guile} -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
;;; 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.
;;
;; 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"))
;;
;; Author: Thien-Thi Nguyen
;;; 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)))
(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

81
scripts/punify Executable file
View file

@ -0,0 +1,81 @@
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts punify)) '\'main')'
exec ${GUILE-guile} -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
;;; 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
;; 81 355 2622 ./punify
;; 0 34 694
;;
;; TODO: Read from stdin.
;; Handle vectors.
;; Identifier punification.
;;
;; Author: Thien-Thi Nguyen
;;; Code:
(define-module (scripts punify)
:export (punify))
(define (write-punily form)
(if (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?)))))
(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

166
scripts/use2dot Executable file
View file

@ -0,0 +1,166 @@
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts use2dot)) '\'main')'
exec ${GUILE-guile} -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
;;; 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.
;;
;; 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:
;; --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)'.
;;
;; TODO
;; - add `--load-synonyms' option
;; - add `--ignore-module' option
;; - handle arbitrary command-line key/value configuration
;;
;; Author: Thien-Thi Nguyen based on PERL script by Keisuke Nishida
;;; Code:
(define-module (scripts use2dot)
:use-module (ice-9 regex))
(define (string-append/separator separator strings)
;; from (ttn stringutils) -- todo: use srfi-13
;; "Append w/ SEPARATOR a list of STRINGS.
;; SEPARATOR can be a character or a string."
(let ((rev (reverse strings))
(sep (if (char? separator)
(make-string 1 separator)
separator)))
(apply string-append
(let loop ((s (cdr rev))
(acc (list (car rev))))
(if (null? s)
acc
(loop (cdr s)
(cons (car s)
(cons sep acc))))))))
(define (mapconcat proc ls sep)
;; from (ttn stringutils) -- todo: use srfi-13
;; "Map PROC over LS, concatening resulting strings with separator SEP."
(string-append/separator sep (map proc ls)))
(define default-module '(guile))
(define (q s) ; quote
(format #f "~S" s))
(define (vv pair) ; var=val
(format #f "~A=~A" (car pair) (cdr pair)))
(define (spew module use . etc)
(and module
(let ((etc-spec (if (null? etc)
""
(format #f " [~A]" (mapconcat vv etc ",")))))
(format #t " \"~A\" -> \"~A\"~A;\n" module use etc-spec))))
(define (header)
(format #t "digraph use2dot {")
(for-each (lambda (s) (format #t " ~A;\n" s))
(map vv `((label . ,(q "Guile Module Dependencies"))
;(rankdir . LR)
;(size . ,(q "7.5,10"))
(ratio . fill)
;(nodesep . ,(q "0.05"))
))))
(define (grok filename)
(let* ((p (open-file filename "r"))
(next (lambda () (read p)))
(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)
(let loop ((ls form))
(or (null? ls)
(case (car ls)
((:use-module)
(spew module (cadr ls))
(loop (cddr ls)))
((:autoload)
(spew module (cadr ls)
'(style . dotted)
'(fontsize . 5)
(let ((len (length (caddr ls))))
`(label . ,(q (number->string len)))))
(loop (cdddr ls)))
(else (loop (cdr ls))))))))
((use-modules)
(for-each (lambda (use)
(spew (or curmod default-module) use))
(cdr form)))
((load primitive-load)
(spew (or curmod default-module)
(let ((file (cadr form)))
(if (string? file)
file
(format #f "[computed in ~A]" filename)))
'(style . bold))))
(loop (next)))))))
(define (body files)
(for-each grok files))
(define (footer)
(format #t "}"))
(define (use2dot . args)
(header)
(let* ((override (cond ((member "--default-module" args) => cadr)
(else #f)))
(files (if override (cddr args) args)))
(and override
(set! default-module
(with-input-from-string override (lambda () (read)))))
(body files))
(footer))
(define main use2dot)
;;; use2dot ends here