mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-09 13:30:26 +02:00
Code Activity

Merge remote-tracking branch 'origin/stable-2.0'

Browse source
This commit is contained in:
Andy Wingo 2011-05-30 11:50:38 +02:00
commit d31d703fd4
13 changed files with 265 additions and 359 deletions
Download patch file Download diff file Expand all files Collapse all files

1
doc/ref/Makefile.am
View file

@ -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 \

26
doc/ref/mod-getopt-long.texi
View file

@ -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}

93
doc/ref/script-getopt.texi
View file

@ -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:

40
libguile/hashtab.c
View file

@ -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);
}
}

13
libguile/r6rs-ports.c
View file

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

162
meta/guile-tools.in
View file

@ -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))))))))

1
module/Makefile.am
View file

@ -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 \

2
module/ice-9/boot-9.scm
View file

@ -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!

113
module/ice-9/getopt-long.scm
View file

@ -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.

8
module/rnrs/io/ports.scm
View file

@ -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))

83
module/scripts/list.scm Normal file
View file

@ -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)

13
test-suite/tests/getopt-long.test
View file

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

69
test-suite/tests/r6rs-ports.test
View file

@ -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"