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

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		\

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
+arguments --- an @dfn{option specification}, and some optional keyword
-line arguments according to the option specification and returns a data
+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}

doc/ref/script-getopt.texi

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

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);
+      for (ls = SCM_SIMPLE_VECTOR_REF (buckets, i); !scm_is_null (ls);
-	   !scm_is_null (ls);
+	   ls = SCM_CDR (ls))
-	   prev = 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_HASHTABLE_WEAK_P (table) && SCM_WEAK_PAIR_DELETED_P (handle))
-	    {
+            /* Don't try to unlink this weak pair, as we're not within
-	      if (SCM_WEAK_PAIR_DELETED_P (handle))
+               the allocation lock.  Instead rely on
-		{
+               vacuum_weak_hash_table to do its job.  */
-		  /* We hit a weak pair whose car/cdr has become
+            continue;
-		     unreachable: unlink it from the bucket.  */
+          else
-		  if (scm_is_true (prev))
+            result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result);
-		    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);
 	}
     }
 

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

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*))
+  (let ((options (getopt-long args *option-grammar*
-    (lambda (options args)
+                              #:stop-at-first-non-option #t)))
-      (cond
+    (cond
-       ((assq 'help options)
+     ((option-ref options 'help #f)
-        (display-help)
+      (display-help)
-        (exit 0))
+      (exit 0))
-       ((assq 'version options)
+     ((option-ref options 'version #f)
-        (display-version)
+      (display-version)
-        (exit 0))
+      (exit 0))
-       ((or (equal? args '())
+     (else
-            (equal? args '("list")))
+      (let ((args (option-ref options '() '())))
-        (list-scripts))
+        (cond ((find-script (if (null? args)
-       ((find-script (car args))
+                                "list"
-        => (lambda (mod)
+                                (car args)))
-             (exit (apply (module-ref mod 'main) (cdr args)))))
+               => (lambda (mod)
-       (else
+                    (exit (apply (module-ref mod 'main) (if (null? args)
-        (format (current-error-port)
+                                                            '()
-                "guile-tools: unknown script ~s~%" (car args))
+                                                            (cdr args))))))
-        (format (current-error-port)
+              (else
-                "Try `guile-tools --help' for more information.~%")
+               (format (current-error-port)
-        (exit 1))))))
+                       "guile-tools: unknown script ~s~%" (car args))
+               (format (current-error-port)
+                       "Try `guile-tools --help' for more information.~%")
+               (exit 1))))))))

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			\

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!

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)
+              (loop (- unclumped 1) ls (acons spec #t found) etc)
-              (val!loop (car ls) (cdr ls) (cons spec 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))
+                (if (> unclumped 0)
-                       (spec (or (assoc-ref sc-idx c)
+                    ;; Next option is known not to be clumped.
-                                 (fatal-error "no such option: -~a" c))))
+                    (let* ((c (match:substring match 1))
-                  (eat! spec rest))))
+                           (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)
+      (for-each (lambda (spec+val)
-            (let ((multi-count (map (lambda (desc)
+                  (set-car! spec+val
-                                      (cons (car desc) 0))
+                            (string->symbol (option-spec->name (car spec+val)))))
-                                    option-desc-list)))
+                found)
-              (map (lambda (spec)
+      (cons (cons '() rest-ls) found))))
-                     (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))))))
 
 (define (option-ref options key default)
   "Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not found.

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

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)

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

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]"
+    (with-fluids ((%default-port-encoding "UTF-8"))
-      (call-with-port (open-file-output-port filename)
+      (pass-if "open-file-output-port [opens binary port]"
-        (lambda (port)
+        (call-with-port (open-file-output-port filename)
-          (put-bytevector port '#vu8(1 2 3))
+          (lambda (port)
-          (binary-port? 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
+       (call-with-bytevector-output-port/transcoded (make-transcoder (utf-8-codec))
-         (lambda (bv-port)
+         (lambda (utf8-port)
-           (call-with-port (transcoded-port bv-port (make-transcoder (utf-8-codec)))
+           (put-string utf8-port s))))))
-             (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"