summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--doc/ref/Makefile.am1
-rw-r--r--doc/ref/mod-getopt-long.texi26
-rw-r--r--doc/ref/script-getopt.texi93
-rw-r--r--libguile/hashtab.c40
-rw-r--r--libguile/r6rs-ports.c13
-rwxr-xr-xmeta/guile-tools.in162
-rw-r--r--module/Makefile.am1
-rw-r--r--module/ice-9/boot-9.scm2
-rw-r--r--module/ice-9/getopt-long.scm113
-rw-r--r--module/rnrs/io/ports.scm8
-rw-r--r--module/scripts/list.scm83
-rw-r--r--test-suite/tests/getopt-long.test13
-rw-r--r--test-suite/tests/r6rs-ports.test69
13 files changed, 265 insertions, 359 deletions
diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am
index 0359380c2..2ccf7dd22 100644
--- a/doc/ref/Makefile.am
+++ b/doc/ref/Makefile.am
@@ -67,7 +67,6 @@ guile_TEXINFOS = preface.texi \
api-deprecated.texi \
scheme-using.texi \
indices.texi \
- script-getopt.texi \
data-rep.texi \
repl-modules.texi \
srfi-modules.texi \
diff --git a/doc/ref/mod-getopt-long.texi b/doc/ref/mod-getopt-long.texi
index 3d753df67..17402151a 100644
--- a/doc/ref/mod-getopt-long.texi
+++ b/doc/ref/mod-getopt-long.texi
@@ -13,8 +13,9 @@ The @code{(ice-9 getopt-long)} module exports two procedures:
@itemize @bullet
@item
@code{getopt-long} takes a list of strings --- the command line
-arguments --- and an @dfn{option specification}. It parses the command
-line arguments according to the option specification and returns a data
+arguments --- an @dfn{option specification}, and some optional keyword
+parameters. It parses the command line arguments according to the
+option specification and keyword parameters, and returns a data
structure that encapsulates the results of the parsing.
@item
@@ -254,7 +255,7 @@ as ordinary argument strings.
@node getopt-long Reference
@subsection Reference Documentation for @code{getopt-long}
-@deffn {Scheme Procedure} getopt-long args grammar
+@deffn {Scheme Procedure} getopt-long args grammar [#:stop-at-first-non-option #t]
Parse the command line given in @var{args} (which must be a list of
strings) according to the option specification @var{grammar}.
@@ -290,6 +291,13 @@ value, and throw an exception if it returns @code{#f}. @var{func}
should be a procedure which accepts a string and returns a boolean
value; you may need to use quasiquotes to get it into @var{grammar}.
@end table
+
+The @code{#:stop-at-first-non-option} keyword, if specified with any
+true value, tells @code{getopt-long} to stop when it gets to the first
+non-option in the command line. That is, at the first word which is
+neither an option itself, nor the value of an option. Everything in the
+command line from that word onwards will be returned as non-option
+arguments.
@end deffn
@code{getopt-long}'s @var{args} parameter is expected to be a list of
@@ -323,6 +331,18 @@ happen using the long option @code{--opt=@var{value}} syntax).
An option predicate fails.
@end itemize
+@code{#:stop-at-first-non-option} is useful for command line invocations
+like @code{guile-tools [--help | --version] [script [script-options]]}
+and @code{cvs [general-options] command [command-options]}, where there
+are options at two levels: some generic and understood by the outer
+command, and some that are specific to the particular script or command
+being invoked. To use @code{getopt-long} in such cases, you would call
+it twice: firstly with @code{#:stop-at-first-non-option #t}, so as to
+parse any generic options and identify the wanted script or sub-command;
+secondly, and after trimming off the initial generic command words, with
+a script- or sub-command-specific option grammar, so as to process those
+specific options.
+
@node option-ref Reference
@subsection Reference Documentation for @code{option-ref}
diff --git a/doc/ref/script-getopt.texi b/doc/ref/script-getopt.texi
deleted file mode 100644
index c7bb0d439..000000000
--- a/doc/ref/script-getopt.texi
+++ /dev/null
@@ -1,93 +0,0 @@
-@c -*-texinfo-*-
-@c This is part of the GNU Guile Reference Manual.
-@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004
-@c Free Software Foundation, Inc.
-@c See the file guile.texi for copying conditions.
-
-@node Command Line Handling
-@section Handling Command Line Options and Arguments
-
-@c This chapter was written and contributed by Martin Grabmueller.
-
-The ability to accept and handle command line arguments is very
-important when writing Guile scripts to solve particular problems, such
-as extracting information from text files or interfacing with existing
-command line applications. This chapter describes how Guile makes
-command line arguments available to a Guile script, and the utilities
-that Guile provides to help with the processing of command line
-arguments.
-
-When a Guile script is invoked, Guile makes the command line arguments
-accessible via the procedure @code{command-line}, which returns the
-arguments as a list of strings.
-
-For example, if the script
-
-@example
-#! /usr/local/bin/guile -s
-!#
-(write (command-line))
-(newline)
-@end example
-
-@noindent
-is saved in a file @file{cmdline-test.scm} and invoked using the command
-line @code{./cmdline-test.scm bar.txt -o foo -frumple grob}, the output
-is
-
-@example
-("./cmdline-test.scm" "bar.txt" "-o" "foo" "-frumple" "grob")
-@end example
-
-If the script invocation includes a @code{-e} option, specifying a
-procedure to call after loading the script, Guile will call that
-procedure with @code{(command-line)} as its argument. So a script that
-uses @code{-e} doesn't need to refer explicitly to @code{command-line}
-in its code. For example, the script above would have identical
-behaviour if it was written instead like this:
-
-@example
-#! /usr/local/bin/guile \
--e main -s
-!#
-(define (main args)
- (write args)
- (newline))
-@end example
-
-(Note the use of the meta switch @code{\} so that the script invocation
-can include more than one Guile option: @xref{The Meta Switch}.)
-
-These scripts use the @code{#!} POSIX convention so that they can be
-executed using their own file names directly, as in the example command
-line @code{./cmdline-test.scm bar.txt -o foo -frumple grob}. But they
-can also be executed by typing out the implied Guile command line in
-full, as in:
-
-@example
-$ guile -s ./cmdline-test.scm bar.txt -o foo -frumple grob
-@end example
-
-@noindent
-or
-
-@example
-$ guile -e main -s ./cmdline-test2.scm bar.txt -o foo -frumple grob
-@end example
-
-Even when a script is invoked using this longer form, the arguments that
-the script receives are the same as if it had been invoked using the
-short form. Guile ensures that the @code{(command-line)} or @code{-e}
-arguments are independent of how the script is invoked, by stripping off
-the arguments that Guile itself processes.
-
-A script is free to parse and handle its command line arguments in any
-way that it chooses. Where the set of possible options and arguments is
-complex, however, it can get tricky to extract all the options, check
-the validity of given arguments, and so on. This task can be greatly
-simplified by taking advantage of the module @code{(ice-9 getopt-long)},
-which is distributed with Guile, @xref{getopt-long}.
-
-@c Local Variables:
-@c TeX-master: "guile.texi"
-@c End:
diff --git a/libguile/hashtab.c b/libguile/hashtab.c
index d70799380..440738c11 100644
--- a/libguile/hashtab.c
+++ b/libguile/hashtab.c
@@ -1377,40 +1377,20 @@ scm_internal_hash_fold (scm_t_hash_fold_fn fn, void *closure,
n = SCM_SIMPLE_VECTOR_LENGTH (buckets);
for (i = 0; i < n; ++i)
{
- SCM prev, ls;
+ SCM ls, handle;
- for (prev = SCM_BOOL_F, ls = SCM_SIMPLE_VECTOR_REF (buckets, i);
- !scm_is_null (ls);
- prev = ls, ls = SCM_CDR (ls))
+ for (ls = SCM_SIMPLE_VECTOR_REF (buckets, i); !scm_is_null (ls);
+ ls = SCM_CDR (ls))
{
- SCM handle;
-
- if (!scm_is_pair (ls))
- SCM_WRONG_TYPE_ARG (SCM_ARG3, buckets);
-
handle = SCM_CAR (ls);
- if (!scm_is_pair (handle))
- SCM_WRONG_TYPE_ARG (SCM_ARG3, buckets);
- if (SCM_HASHTABLE_WEAK_P (table))
- {
- if (SCM_WEAK_PAIR_DELETED_P (handle))
- {
- /* We hit a weak pair whose car/cdr has become
- unreachable: unlink it from the bucket. */
- if (scm_is_true (prev))
- SCM_SETCDR (prev, SCM_CDR (ls));
- else
- SCM_SIMPLE_VECTOR_SET (buckets, i, SCM_CDR (ls));
-
- /* Update the item count. */
- SCM_HASHTABLE_DECREMENT (table);
-
- continue;
- }
- }
-
- result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result);
+ if (SCM_HASHTABLE_WEAK_P (table) && SCM_WEAK_PAIR_DELETED_P (handle))
+ /* Don't try to unlink this weak pair, as we're not within
+ the allocation lock. Instead rely on
+ vacuum_weak_hash_table to do its job. */
+ continue;
+ else
+ result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result);
}
}
diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
index 308f17a94..bf146ef15 100644
--- a/libguile/r6rs-ports.c
+++ b/libguile/r6rs-ports.c
@@ -1179,12 +1179,21 @@ tp_flush (SCM port)
scm_t_port *c_port = SCM_PTAB_ENTRY (port);
size_t count = c_port->write_pos - c_port->write_buf;
- scm_c_write (binary_port, c_port->write_buf, count);
+ /* As the runtime will try to flush all ports upon exit, we test for
+ the underlying port still being open here. Otherwise, when you
+ would explicitly close the underlying port and the transcoded port
+ still had data outstanding, you'd get an exception on Guile exit.
+
+ We just throw away the data when the underlying port is closed. */
+
+ if (SCM_OPOUTPORTP (binary_port))
+ scm_c_write (binary_port, c_port->write_buf, count);
c_port->write_pos = c_port->write_buf;
c_port->rw_active = SCM_PORT_NEITHER;
- scm_force_output (binary_port);
+ if (SCM_OPOUTPORTP (binary_port))
+ scm_force_output (binary_port);
}
static int
diff --git a/meta/guile-tools.in b/meta/guile-tools.in
index 7f156ffd9..2f335b8f7 100755
--- a/meta/guile-tools.in
+++ b/meta/guile-tools.in
@@ -24,7 +24,7 @@ exec guile $GUILE_FLAGS -e '(@@ (guile-tools) main)' -s "$0" "$@"
;;;; Boston, MA 02110-1301 USA
(define-module (guile-tools)
- #:use-module ((srfi srfi-1) #:select (fold append-map))
+ #:use-module (ice-9 getopt-long)
#:autoload (ice-9 format) (format))
;; Hack to provide scripts with the bug-report address.
@@ -55,146 +55,34 @@ This is free software: you are free to change and redistribute it.
There is NO WARRANTY, to the extent permitted by law.
" (version) (effective-version)))
-(define (directory-files dir)
- (if (and (file-exists? dir) (file-is-directory? dir))
- (let ((dir-stream (opendir dir)))
- (let loop ((new (readdir dir-stream))
- (acc '()))
- (if (eof-object? new)
- (begin
- (closedir dir-stream)
- acc)
- (loop (readdir dir-stream)
- (if (or (string=? "." new) ; ignore
- (string=? ".." new)) ; ignore
- acc
- (cons new acc))))))
- '()))
-
-(define (strip-extensions path)
- (or-map (lambda (ext)
- (and
- (string-suffix? ext path)
- (substring path 0
- (- (string-length path) (string-length ext)))))
- (append %load-compiled-extensions %load-extensions)))
-
-(define (unique l)
- (cond ((null? l) l)
- ((null? (cdr l)) l)
- ((equal? (car l) (cadr l)) (unique (cdr l)))
- (else (cons (car l) (unique (cdr l))))))
-
-(define (find-submodules head)
- (let ((shead (map symbol->string head)))
- (unique
- (sort
- (append-map (lambda (path)
- (fold (lambda (x rest)
- (let ((stripped (strip-extensions x)))
- (if stripped (cons stripped rest) rest)))
- '()
- (directory-files
- (fold (lambda (x y) (in-vicinity y x)) path shead))))
- %load-path)
- string<?))))
-
-(define (list-scripts)
- (for-each (lambda (x)
- ;; would be nice to show a summary.
- (format #t "~A\n" x))
- (find-submodules '(scripts))))
-
(define (find-script s)
(resolve-module (list 'scripts (string->symbol s)) #:ensure #f))
-(define (getopt args grammar)
- (define (fail)
- (format (current-error-port)
- "Try `guile-tools --help' for more information.~%")
- (exit 1))
-
- (define (unrecognized-arg arg)
- (format (current-error-port)
- "guile-tools: unrecognized option: `~a'~%" arg)
- (fail))
-
- (define (unexpected-value sym val)
- (format (current-error-port)
- "guile-tools: option `--~a' does not take an argument (given ~s)~%"
- sym val)
- (fail))
-
- (define (single-char-table grammar)
- (cond
- ((null? grammar) '())
- ((assq 'single-char (cdar grammar))
- => (lambda (form)
- (acons (cadr form) (car grammar)
- (single-char-table (cdr grammar)))))
- (else
- (single-char-table (cdr grammar)))))
-
- (let ((single (single-char-table grammar)))
- (let lp ((args (cdr args)) (options '()))
- (cond
- ((or (null? args) (equal? (car args) "-"))
- (values (reverse options) args))
- ((equal? (car args) "--")
- (values (reverse options) (cdr args)))
- ((string-prefix? "--" (car args))
- (let* ((str (car args))
- (eq (string-index str #\= 2))
- (sym (string->symbol
- (substring str 2 (or eq (string-length str)))))
- (val (and eq (substring str (1+ eq))))
- (spec (assq sym grammar)))
- (cond
- ((not spec)
- (unrecognized-arg (substring str 0 (or eq (string-length str)))))
- (val
- ;; no values for now
- (unexpected-value sym val))
- ((assq-ref (cdr spec) 'value)
- (error "options with values not supported right now"))
- (else
- (lp (cdr args) (acons sym #f options))))))
- ((string-prefix? "-" (car args))
- (let lp* ((chars (cdr (string->list (car args)))) (options options))
- (if (null? chars)
- (lp (cdr args) options)
- (let ((spec (assv-ref single (car chars))))
- (cond
- ((not spec)
- (unrecognized-arg (string #\- (car chars))))
- ((assq-ref (cdr spec) 'value)
- (error "options with values not supported right now"))
- (else
- (lp* (cdr chars) (acons (car spec) #f options))))))))
- (else (values (reverse options) args))))))
-
(define (main args)
(if (defined? 'setlocale)
(setlocale LC_ALL ""))
- (call-with-values (lambda () (getopt args *option-grammar*))
- (lambda (options args)
- (cond
- ((assq 'help options)
- (display-help)
- (exit 0))
- ((assq 'version options)
- (display-version)
- (exit 0))
- ((or (equal? args '())
- (equal? args '("list")))
- (list-scripts))
- ((find-script (car args))
- => (lambda (mod)
- (exit (apply (module-ref mod 'main) (cdr args)))))
- (else
- (format (current-error-port)
- "guile-tools: unknown script ~s~%" (car args))
- (format (current-error-port)
- "Try `guile-tools --help' for more information.~%")
- (exit 1))))))
+ (let ((options (getopt-long args *option-grammar*
+ #:stop-at-first-non-option #t)))
+ (cond
+ ((option-ref options 'help #f)
+ (display-help)
+ (exit 0))
+ ((option-ref options 'version #f)
+ (display-version)
+ (exit 0))
+ (else
+ (let ((args (option-ref options '() '())))
+ (cond ((find-script (if (null? args)
+ "list"
+ (car args)))
+ => (lambda (mod)
+ (exit (apply (module-ref mod 'main) (if (null? args)
+ '()
+ (cdr args))))))
+ (else
+ (format (current-error-port)
+ "guile-tools: unknown script ~s~%" (car args))
+ (format (current-error-port)
+ "Try `guile-tools --help' for more information.~%")
+ (exit 1))))))))
diff --git a/module/Makefile.am b/module/Makefile.am
index 42aff1833..ddd46749f 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -155,6 +155,7 @@ SCRIPTS_SOURCES = \
scripts/frisk.scm \
scripts/generate-autoload.scm \
scripts/lint.scm \
+ scripts/list.scm \
scripts/punify.scm \
scripts/read-scheme-source.scm \
scripts/read-text-outline.scm \
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 0493de514..7c9e3c5eb 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -682,7 +682,7 @@ If there is no handler at all, Guile prints an error and then exits."
(let ((filename (or (cadr source) "<unnamed port>"))
(line (caddr source))
(col (cdddr source)))
- (format port "~a:~a:~a: " filename line col))
+ (format port "~a:~a:~a: " filename (1+ line) col))
(format port "ERROR: "))))
(set! set-exception-printer!
diff --git a/module/ice-9/getopt-long.scm b/module/ice-9/getopt-long.scm
index 1b170b494..12f8c94c3 100644
--- a/module/ice-9/getopt-long.scm
+++ b/module/ice-9/getopt-long.scm
@@ -161,6 +161,7 @@
#:use-module (srfi srfi-9)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
+ #:use-module (ice-9 optargs)
#:export (getopt-long option-ref))
(define %program-name (make-fluid))
@@ -179,8 +180,6 @@
option-spec?
(name
option-spec->name set-option-spec-name!)
- (value
- option-spec->value set-option-spec-value!)
(required?
option-spec->required? set-option-spec-required?!)
(option-spec->single-char
@@ -228,33 +227,12 @@
(define long-opt-no-value-rx (make-regexp "^--([^=]+)$"))
(define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)"))
-(define (expand-clumped-singles opt-ls)
- ;; example: ("--xyz" "-abc5d") => ("--xyz" "-a" "-b" "-c" "5d")
- (let loop ((opt-ls opt-ls) (ret-ls '()))
- (cond ((null? opt-ls)
- (reverse ret-ls)) ;;; retval
- ((regexp-exec short-opt-rx (car opt-ls))
- => (lambda (match)
- (let ((singles (reverse
- (map (lambda (c)
- (string-append "-" (make-string 1 c)))
- (string->list
- (match:substring match 1)))))
- (extra (match:substring match 2)))
- (loop (cdr opt-ls)
- (append (if (string=? "" extra)
- singles
- (cons extra singles))
- ret-ls)))))
- (else (loop (cdr opt-ls)
- (cons (car opt-ls) ret-ls))))))
-
(define (looks-like-an-option string)
(or (regexp-exec short-opt-rx string)
(regexp-exec long-opt-with-value-rx string)
(regexp-exec long-opt-no-value-rx string)))
-(define (process-options specs argument-ls)
+(define (process-options specs argument-ls stop-at-first-non-option)
;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
;; FOUND is an unordered list of option specs for found options, while ETC
;; is an order-maintained list of elements in ARGUMENT-LS that are neither
@@ -266,32 +244,22 @@
(cons (make-string 1 (option-spec->single-char spec))
spec))
(remove-if-not option-spec->single-char specs))))
- (let loop ((argument-ls argument-ls) (found '()) (etc '()))
+ (let loop ((unclumped 0) (argument-ls argument-ls) (found '()) (etc '()))
(define (eat! spec ls)
- (define (val!loop val n-ls n-found n-etc)
- (set-option-spec-value!
- spec
- ;; handle multiple occurrances
- (cond ((option-spec->value spec)
- => (lambda (cur)
- ((if (list? cur) cons list)
- val cur)))
- (else val)))
- (loop n-ls n-found n-etc))
(cond
((eq? 'optional (option-spec->value-policy spec))
(if (or (null? ls)
(looks-like-an-option (car ls)))
- (val!loop #t ls (cons spec found) etc)
- (val!loop (car ls) (cdr ls) (cons spec found) etc)))
+ (loop (- unclumped 1) ls (acons spec #t found) etc)
+ (loop (- unclumped 2) (cdr ls) (acons spec (car ls) found) etc)))
((eq? #t (option-spec->value-policy spec))
(if (or (null? ls)
(looks-like-an-option (car ls)))
(fatal-error "option must be specified with argument: --~a"
(option-spec->name spec))
- (val!loop (car ls) (cdr ls) (cons spec found) etc)))
+ (loop (- unclumped 2) (cdr ls) (acons spec (car ls) found) etc)))
(else
- (val!loop #t ls (cons spec found) etc))))
+ (loop (- unclumped 1) ls (acons spec #t found) etc))))
(match argument-ls
(()
@@ -300,10 +268,24 @@
(cond
((regexp-exec short-opt-rx opt)
=> (lambda (match)
- (let* ((c (match:substring match 1))
- (spec (or (assoc-ref sc-idx c)
- (fatal-error "no such option: -~a" c))))
- (eat! spec rest))))
+ (if (> unclumped 0)
+ ;; Next option is known not to be clumped.
+ (let* ((c (match:substring match 1))
+ (spec (or (assoc-ref sc-idx c)
+ (fatal-error "no such option: -~a" c))))
+ (eat! spec rest))
+ ;; Expand a clumped group of short options.
+ (let* ((extra (match:substring match 2))
+ (unclumped-opts
+ (append (map (lambda (c)
+ (string-append "-" (make-string 1 c)))
+ (string->list
+ (match:substring match 1)))
+ (if (string=? "" extra) '() (list extra)))))
+ (loop (length unclumped-opts)
+ (append unclumped-opts rest)
+ found
+ etc)))))
((regexp-exec long-opt-no-value-rx opt)
=> (lambda (match)
(let* ((opt (match:substring match 1))
@@ -319,10 +301,14 @@
(eat! spec (cons (match:substring match 2) rest))
(fatal-error "option does not support argument: --~a"
opt)))))
+ ((and stop-at-first-non-option
+ (<= unclumped 0))
+ (cons found (append (reverse etc) argument-ls)))
(else
- (loop rest found (cons opt etc)))))))))
+ (loop (- unclumped 1) rest found (cons opt etc)))))))))
-(define (getopt-long program-arguments option-desc-list)
+(define* (getopt-long program-arguments option-desc-list
+ #:key stop-at-first-non-option)
"Process options, handling both long and short options, similar to
the glibc function 'getopt_long'. PROGRAM-ARGUMENTS should be a value
similar to what (program-arguments) returns. OPTION-DESC-LIST is a
@@ -356,44 +342,27 @@ to add a `single-char' clause to the option description."
(with-fluids ((%program-name (car program-arguments)))
(let* ((specifications (map parse-option-spec option-desc-list))
(pair (split-arg-list (cdr program-arguments)))
- (split-ls (expand-clumped-singles (car pair)))
+ (split-ls (car pair))
(non-split-ls (cdr pair))
- (found/etc (process-options specifications split-ls))
+ (found/etc (process-options specifications split-ls
+ stop-at-first-non-option))
(found (car found/etc))
(rest-ls (append (cdr found/etc) non-split-ls)))
(for-each (lambda (spec)
(let ((name (option-spec->name spec))
- (val (option-spec->value spec)))
+ (val (assq-ref found spec)))
(and (option-spec->required? spec)
- (or (memq spec found)
+ (or val
(fatal-error "option must be specified: --~a"
name)))
- (and (memq spec found)
- (eq? #t (option-spec->value-policy spec))
- (or val
- (fatal-error
- "option must be specified with argument: --~a"
- name)))
(let ((pred (option-spec->predicate spec)))
(and pred (pred name val)))))
specifications)
- (cons (cons '() rest-ls)
- (let ((multi-count (map (lambda (desc)
- (cons (car desc) 0))
- option-desc-list)))
- (map (lambda (spec)
- (let ((name (string->symbol (option-spec->name spec))))
- (cons name
- ;; handle multiple occurrances
- (let ((maybe-ls (option-spec->value spec)))
- (if (list? maybe-ls)
- (let* ((look (assq name multi-count))
- (idx (cdr look))
- (val (list-ref maybe-ls idx)))
- (set-cdr! look (1+ idx)) ; ugh!
- val)
- maybe-ls)))))
- found))))))
+ (for-each (lambda (spec+val)
+ (set-car! spec+val
+ (string->symbol (option-spec->name (car spec+val)))))
+ found)
+ (cons (cons '() rest-ls) found))))
(define (option-ref options key default)
"Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found.
diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm
index 4ae01be68..246e46b39 100644
--- a/module/rnrs/io/ports.scm
+++ b/module/rnrs/io/ports.scm
@@ -311,7 +311,9 @@ read from/written to in @var{port}."
(buffer-mode (buffer-mode block))
maybe-transcoder)
(let ((port (with-i/o-filename-conditions filename
- (lambda () (open filename O_RDONLY)))))
+ (lambda ()
+ (with-fluids ((%default-port-encoding #f))
+ (open filename O_RDONLY))))))
(cond (maybe-transcoder
(set-port-encoding! port (transcoder-codec maybe-transcoder))))
port))
@@ -340,7 +342,9 @@ as a string, and a thunk to retrieve the characters associated with that port."
0
O_EXCL)))
(port (with-i/o-filename-conditions filename
- (lambda () (open filename flags)))))
+ (lambda ()
+ (with-fluids ((%default-port-encoding #f))
+ (open filename flags))))))
(cond (maybe-transcoder
(set-port-encoding! port (transcoder-codec maybe-transcoder))))
port))
diff --git a/module/scripts/list.scm b/module/scripts/list.scm
new file mode 100644
index 000000000..046d8f5b8
--- /dev/null
+++ b/module/scripts/list.scm
@@ -0,0 +1,83 @@
+;;; List --- List scripts that can be invoked by guile-tools -*- coding: iso-8859-1 -*-
+
+;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library 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
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free
+;;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;;;; Boston, MA 02110-1301 USA
+
+;;; Commentary:
+
+;; Usage: list
+;;
+;; List scripts that can be invoked by guile-tools.
+
+;;; Code:
+
+(define-module (scripts list)
+ #:use-module ((srfi srfi-1) #:select (fold append-map))
+ #:export (list-scripts))
+
+
+(define (directory-files dir)
+ (if (and (file-exists? dir) (file-is-directory? dir))
+ (let ((dir-stream (opendir dir)))
+ (let loop ((new (readdir dir-stream))
+ (acc '()))
+ (if (eof-object? new)
+ (begin
+ (closedir dir-stream)
+ acc)
+ (loop (readdir dir-stream)
+ (if (or (string=? "." new) ; ignore
+ (string=? ".." new)) ; ignore
+ acc
+ (cons new acc))))))
+ '()))
+
+(define (strip-extensions path)
+ (or-map (lambda (ext)
+ (and
+ (string-suffix? ext path)
+ (substring path 0
+ (- (string-length path) (string-length ext)))))
+ (append %load-compiled-extensions %load-extensions)))
+
+(define (unique l)
+ (cond ((null? l) l)
+ ((null? (cdr l)) l)
+ ((equal? (car l) (cadr l)) (unique (cdr l)))
+ (else (cons (car l) (unique (cdr l))))))
+
+(define (find-submodules head)
+ (let ((shead (map symbol->string head)))
+ (unique
+ (sort
+ (append-map (lambda (path)
+ (fold (lambda (x rest)
+ (let ((stripped (strip-extensions x)))
+ (if stripped (cons stripped rest) rest)))
+ '()
+ (directory-files
+ (fold (lambda (x y) (in-vicinity y x)) path shead))))
+ %load-path)
+ string<?))))
+
+(define (list-scripts . args)
+ (for-each (lambda (x)
+ ;; would be nice to show a summary.
+ (format #t "~A\n" x))
+ (find-submodules '(scripts))))
+
+(define main list-scripts)
diff --git a/test-suite/tests/getopt-long.test b/test-suite/tests/getopt-long.test
index d7f518482..4ae604883 100644
--- a/test-suite/tests/getopt-long.test
+++ b/test-suite/tests/getopt-long.test
@@ -252,7 +252,7 @@
)
-(with-test-prefix "multiple occurrances"
+(with-test-prefix "multiple occurrences"
(define (test9 . args)
(equal? (getopt-long (cons "foo" args)
@@ -288,4 +288,15 @@
)
+(with-test-prefix "stop-at-first-non-option"
+
+ (pass-if "guile-tools compile example"
+ (equal? (getopt-long '("guile-tools" "compile" "-Wformat" "eval.scm" "-o" "eval.go")
+ '((help (single-char #\h))
+ (version (single-char #\v)))
+ #:stop-at-first-non-option #t)
+ '((() "compile" "-Wformat" "eval.scm" "-o" "eval.go"))))
+
+ )
+
;;; getopt-long.test ends here
diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test
index 7a382b75b..f3e8c2c5d 100644
--- a/test-suite/tests/r6rs-ports.test
+++ b/test-suite/tests/r6rs-ports.test
@@ -27,12 +27,6 @@
#:use-module (rnrs exceptions)
#:use-module (rnrs bytevectors))
-;;; All these tests assume Guile 1.8's port system, where characters are
-;;; treated as octets.
-
-;; Set the default encoding of future ports to be Latin-1.
-(fluid-set! %default-port-encoding #f)
-
(define-syntax pass-if-condition
(syntax-rules ()
((_ name predicate body0 body ...)
@@ -72,6 +66,12 @@
(lambda () #t)) ;; close-port
"rw")))
+(define (call-with-bytevector-output-port/transcoded transcoder receiver)
+ (call-with-bytevector-output-port
+ (lambda (bv-port)
+ (call-with-port (transcoded-port bv-port transcoder)
+ receiver))))
+
(with-test-prefix "7.2.5 End-of-File Object"
@@ -316,6 +316,22 @@
(with-test-prefix "7.2.7 Input Ports"
+ (let ((filename (test-file))
+ (contents (string->utf8 "GNU λ")))
+
+ ;; Create file
+ (call-with-output-file filename
+ (lambda (port) (put-bytevector port contents)))
+
+ (pass-if "open-file-input-port [opens binary port]"
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (call-with-port (open-file-input-port filename)
+ (lambda (port)
+ (and (binary-port? port)
+ (bytevector=? contents (get-bytevector-all port)))))))
+
+ (delete-file filename))
+
;; This section appears here so that it can use the binary input
;; primitives.
@@ -463,11 +479,12 @@
(with-test-prefix "8.2.10 Output ports"
(let ((filename (test-file)))
- (pass-if "open-file-output-port [opens binary port]"
- (call-with-port (open-file-output-port filename)
- (lambda (port)
- (put-bytevector port '#vu8(1 2 3))
- (binary-port? port))))
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (pass-if "open-file-output-port [opens binary port]"
+ (call-with-port (open-file-output-port filename)
+ (lambda (port)
+ (put-bytevector port '#vu8(1 2 3))
+ (binary-port? port)))))
(pass-if-condition "open-file-output-port [exception: already-exists]"
i/o-file-already-exists-error?
@@ -620,11 +637,9 @@
(let ((s "Hello\nÄÖÜ"))
(bytevector=?
(string->utf8 s)
- (call-with-bytevector-output-port
- (lambda (bv-port)
- (call-with-port (transcoded-port bv-port (make-transcoder (utf-8-codec)))
- (lambda (utf8-port)
- (put-string utf8-port s))))))))
+ (call-with-bytevector-output-port/transcoded (make-transcoder (utf-8-codec))
+ (lambda (utf8-port)
+ (put-string utf8-port s))))))
(pass-if "transcoded-port [input]"
(let ((s "Hello\nÄÖÜ"))
@@ -720,6 +735,11 @@
(pass-if-condition "get-datum" i/o-read-error?
(get-datum (make-failing-port)))))
+(define (encoding-error-predicate char)
+ (lambda (c)
+ (and (i/o-encoding-error? c)
+ (char=? char (i/o-encoding-error-char c)))))
+
(with-test-prefix "8.2.12 Textual Output"
(with-test-prefix "write error"
@@ -728,7 +748,22 @@
(pass-if-condition "put-string" i/o-write-error?
(put-string (make-failing-port) "Hello World!"))
(pass-if-condition "put-datum" i/o-write-error?
- (put-datum (make-failing-port) '(hello world!)))))
+ (put-datum (make-failing-port) '(hello world!))))
+ (with-test-prefix "encoding error"
+ (pass-if-condition "put-char" (encoding-error-predicate #\λ)
+ (call-with-bytevector-output-port/transcoded
+ (make-transcoder (latin-1-codec)
+ (native-eol-style)
+ (error-handling-mode raise))
+ (lambda (port)
+ (put-char port #\λ))))
+ (pass-if-condition "put-string" (encoding-error-predicate #\λ)
+ (call-with-bytevector-output-port/transcoded
+ (make-transcoder (latin-1-codec)
+ (native-eol-style)
+ (error-handling-mode raise))
+ (lambda (port)
+ (put-string port "FooλBar"))))))
(with-test-prefix "8.3 Simple I/O"
(with-test-prefix "read error"