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

Conflicts:
	GUILE-VERSION
	libguile/array-map.c
	libguile/fports.h
	libguile/gc.h
	libguile/inline.h
	libguile/ports.c
	libguile/ports.h
	libguile/print.c
	libguile/r6rs-ports.c
	libguile/read.c
	test-suite/tests/00-socket.test

NEWS

@@ -5,23 +5,28 @@ See the end for copying conditions.
 Please send Guile bug reports to bug-guile@gnu.org.
 
 
-Changes in 2.0.8 (since 2.0.7):
+Changes in 2.0.9 (since 2.0.7):
 
-* TODO
+Note: 2.0.8 was a brown paper bag release that was never announced, but
-
+some mirrors may have picked it up.  Please do not use it.
-Reorder points in order of importance and make comprehensible
-
-Assemble thanks
-
-file name docs
-
-gnulib version
-
---language docs
 
 * Notable changes
 
-** New guile.m4.
+** New keyword arguments for procedures that open files
+
+The following procedures that open files now support keyword arguments
+to request binary I/O or to specify the character encoding for text
+files: `open-file', `open-input-file', `open-output-file',
+`call-with-input-file', `call-with-output-file', `with-input-from-file',
+`with-output-to-file', and `with-error-to-file'.
+
+It is also now possible to specify whether Guile should scan files for
+Emacs-style coding declarations.  This scan was done by default in
+versions 2.0.0 through 2.0.7, but now must be explicitly requested.
+
+See "File Ports" in the manual for details.
+
+** Rewritten guile.m4
 
 The `guile.m4' autoconf macros have been rewritten to use `guild' and
 `pkg-config' instead of the deprecated `guile-config' (which itself
@@ -31,11 +36,11 @@ There is also a new macro, `GUILE_PKG', which allows packages to select
 the version of Guile that they want to compile against.  See "Autoconf
 Macros" in the manual, for more information.
 
-** Better Windows support.
+** Better Windows support
 
 Guile now correctly identifies absolute paths on Windows (MinGW), and
 creates files on that platform according to its path conventions.  See
-XXX in the manual, for all details.
+"File System" in the manual, for all details.
 
 In addition, the new Gnulib imports provide `select' and `poll' on
 Windows builds.
@@ -43,17 +48,28 @@ Windows builds.
 As an incompatible change, systems that are missing <sys/select.h> were
 previously provided a public `scm_std_select' C function that defined a
 version of `select', but unhappily it also provided its own incompatible
-definitions for FD_SET, FD_ZERO, and other system interface.  Guile
+definitions for FD_SET, FD_ZERO, and other system interfaces.  Guile
 should not be setting these macros in public API, so this interface was
 removed on those plaforms (basically only MinGW).
 
-** Gnulib update.
+** Numerics improvements
 
-Guile's copy of Gnulib was updated to v0.0-7865-ga828bb2.  The following
+`number->string' now reliably outputs enough digits to produce the same
-modules were imported from Gnulib: select, times, pipe-posix, fstat,
+number when read back in.  Previously, it mishandled subnormal numbers
-getlogin, and poll.
+(printing them as "#.#"), and failed to distinguish between some
+distinct inexact numbers, e.g. 1.0 and (+ 1.0 (expt 2.0 -52)).  These
+problems had far-reaching implications, since the compiler uses
+`number->string' to serialize numeric constants into .go files.
 
-** New optimizations.
+`sqrt' now produces exact rational results when possible, and handles
+very large or very small numbers more robustly.
+
+A number (ahem) of operations involving exact rationals have been
+optimized, most notably `integer-expt' and `expt'.
+
+`exact->inexact' now performs correct IEEE rounding.
+
+** New optimizations
 
 There were a number of improvements to the partial evaluator, allowing
 complete reduction of forms such as:
@@ -62,36 +78,61 @@ complete reduction of forms such as:
 
   ((lambda _ _))
 
-  (apply (lambda _) 1 2 3 4)
+  (apply (lambda _ _) 1 2 3 '(4))
 
   (call-with-values (lambda () (values 1 2)) (lambda _ _))
 
-A number (ahem) of numeric operations on have been made faster, among
+`string-join' now handles huge lists efficiently.
-them GCD and logarithms.
 
-Finally, `array-ref' and `array-set!' on arrays of rank 1 or 2 is now
+`get-bytevector-some' now uses buffered input, which is much faster.
-faster, because it avoids building a rest list.
 
-** `include' resolves relative file names relative to including file.
+Finally, `array-ref', `array-set!' on arrays of rank 1 or 2 is now
+faster, because it avoids building a rest list.  Similarly, the
+one-argument case of `array-for-each' and `array-map!' has been
+optimized, and `array-copy!' and `array-fill!' are faster.
+
+** `peek-char' no longer consumes EOF
+
+As required by the R5RS, if `peek-char' returns EOF, then the next read
+will also return EOF.  Previously `peek-char' would consume the EOF.
+This makes a difference for terminal devices where it is possible to
+read past an EOF.
+
+** Gnulib update
+
+Guile's copy of Gnulib was updated to v0.0-7865-ga828bb2.  The following
+modules were imported from Gnulib: select, times, pipe-posix, fstat,
+getlogin, poll, and c-strcase.
+
+** `include' resolves relative file names relative to including file
 
 Given a relative file name, `include' will look for it relative to the
 directory of the including file.  This harmonizes the behavior of
 `include' with that of `load'.
 
-** SLIB compatibility restored.
+** SLIB compatibility restored
 
 Guile 2.0.8 is now compatible with SLIB.  You will have to use a
 development version of SLIB, however, until a new version of SLIB is
 released.
 
-** Better ,trace REPL command.
+** Better ,trace REPL command
 
 Sometimes the ,trace output for nested function calls could overflow the
 terminal width, which wasn't useful.  Now there is a limit to the amount
 of space the prefix will take.  See the documentation for ",trace" for
 more information.
 
-** Update predefined character sets to Unicode 6.2.
+** Better docstring syntax supported for `case-lambda'
+
+Docstrings can now be placed immediately after the `case-lambda' or
+`case-lambda*' keyword.  See "Case-lambda" in the manual.
+
+** Improved handling of Unicode byte order marks
+
+See "BOM Handling" in the manual for details.
+
+** Update predefined character sets to Unicode 6.2
 
 ** GMP 4.2 or later required
 
@@ -100,17 +141,17 @@ and now requires at least version 4.2 (released in March 2006).
 
 * Manual updates
 
-** Better SXML documentation.
+** Better SXML documentation
 
 The documentation for SXML modules was much improved, though there is
 still far to go.  See "SXML" in manual.
 
-** Style updates.
+** Style updates
 
 Use of "iff" was replaced with standard English.  Keyword arguments are
 now documented consistently, along with their default values.
 
-** An end to the generated-documentation experiment.
+** An end to the generated-documentation experiment
 
 When Guile 2.0 imported some modules from Guile-Lib, they came with a
 system that generated documentation from docstrings and module
@@ -119,19 +160,20 @@ bullet and incorporated these modules into the main text, and will be
 improving them manually over time, as is the case with SXML.  Help is
 appreciated.
 
-** New documentation.
+** New documentation
 
 There is now documentation for `scm_array_type', and `scm_array_ref', as
 well as for the new `array-length' / 'scm_c_array_length' /
 `scm_array_length' functions.  `array-in-bounds?' has better
 documentation as well.  The `program-arguments-alist' and
-`program-lambda-list' functions are now documented.  Finally, the GOOPS
+`program-lambda-list' functions are now documented, as well as `and=>',
-class hierarchy diagram has been regenerated for the web and print
+`exit', and `quit'.  The (system repl server) module is now documented
-output formats.
+(see REPL Servers).  Finally, the GOOPS class hierarchy diagram has been
+regenerated for the web and print output formats.
 
 * New deprecations
 
-** Deprecate generalized vector interface.
+** Deprecate generalized vector interface
 
 The generalized vector interface, introduced in 1.8.0, is simply a
 redundant, verbose interface to arrays of rank 1.  `array-ref' and
@@ -140,59 +182,47 @@ similar functions are entirely sufficient.  Thus,
 `scm_generalized_vector_ref', `scm_generalized_vector_set_x', and
 `scm_generalized_vector_to_list' are now deprecated.
 
-** Deprecate SCM_CHAR_CODE_LIMIT and char-code-limit.
+** Deprecate SCM_CHAR_CODE_LIMIT and char-code-limit
 
 These constants were defined to 256, which is not the highest codepoint
 supported by Guile.  Given that they were useless and incorrect, they
 have been deprecated.
 
-** Deprecate `http-get*'.
+** Deprecate `http-get*'
 
 The new `#:streaming?' argument to `http-get' subsumes the functionality
 of `http-get*' (introduced in 2.0.7).  Also, the `#:extra-headers'
 argument is deprecated in favor of `#:headers'.
 
-** Deprecate (ice-9 mapping).
+** Deprecate (ice-9 mapping)
 
 This module, present in Guile since 1996 but never used or documented,
 has never worked in Guile 2.0.  It has now been deprecated and will be
 removed in Guile 2.2.
 
+** Deprecate undocumented array-related C functions
+
+These are `scm_array_fill_int', `scm_ra_eqp', `scm_ra_lessp',
+`scm_ra_leqp', `scm_ra_grp', `scm_ra_greqp', `scm_ra_sum',
+`scm_ra_product', `scm_ra_difference', `scm_ra_divide', and
+`scm_array_identity'.
+
 * New interfaces
 
-** `round-ash', a bit-shifting operator that rounds on right-shift.
+** SRFI-41 Streams
 
-See "Bitwise Operations".
+See "SRFI-41" in the manual.
 
-** New environment variables: `GUILE_STACK_SIZE', `GUILE_INSTALL_LOCALE'.
+** SRFI-45 exports `promise?'
 
-See "Environment Variables".
+SRFI-45 now exports a `promise?' procedure that works with its promises.
+Also, its promises now print more nicely.
 
-** New procedure `sendfile'.
+** New HTTP client procedures
 
-See "File System".
+See "Web Client" for documentation on the new `http-head', `http-post',
-
+`http-put', `http-delete', `http-trace', and `http-options' procedures,
-** New procedures for dealing with file names.
+and also for more options to `http-get'.
-
-See XXX for documentation on `system-file-name-convention',
-`file-name-separator?', `absolute-file-name?', and
-`file-name-separator-string'.
-
-** `array-length', an array's first dimension.
-
-See "Array Procedures".
-
-** `hash-count', for hash tables.
-
-See "Hash Tables".
-
-** New foreign types: `ssize_t', `ptrdiff_t'.
-    
-See "Foreign Types".
-
-** New C helpers: `scm_from_ptrdiff_t', `scm_to_ptrdiff_t'.
-
-See "Integers".
 
 ** Much more capable `xml->sxml'
 
@@ -201,11 +231,73 @@ parser deals with namespaces, processed entities, doctypes, and literal
 strings.  Incidentally, `current-ssax-error-port' is now a parameter
 object.
 
-** New command-line argument: `--language'
+** New procedures for converting strings to and from bytevectors
 
-See XXX in the manual.
+See "Representing Strings as Bytes" for documention on the new `(ice-9
+iconv)' module and its `bytevector->string' and `string->bytevector'
+procedures.
 
-** `current-language' in default environment.
+** Escape continuations with `call/ec' and `let/ec'
+
+See "Prompt Primitives".
+
+** New procedures to read all characters from a port
+
+See "Line/Delimited" in the manual for documentation on `read-string'
+ and `read-string!'.
+
+** New procedure `sendfile'
+
+See "File System".
+
+** New procedure `unget-bytevector'
+
+See "R6RS Binary Input".
+
+** New C helper: `scm_c_bind_keyword_arguments'
+
+See "Keyword Procedures".
+
+** New command-line arguments: `--language' and `-C'
+
+See "Command-line Options" in the manual.
+
+** New environment variables: `GUILE_STACK_SIZE', `GUILE_INSTALL_LOCALE'
+
+See "Environment Variables".
+
+** New procedures for dealing with file names
+
+See "File System" for documentation on `system-file-name-convention',
+`file-name-separator?', `absolute-file-name?', and
+`file-name-separator-string'.
+
+** `array-length', an array's first dimension
+
+See "Array Procedures".
+
+** `hash-count', for hash tables
+
+See "Hash Tables".
+
+** `round-ash', a bit-shifting operator that rounds on right-shift
+
+See "Bitwise Operations".
+
+** New foreign types: `ssize_t', `ptrdiff_t'
+    
+See "Foreign Types".
+
+** New C helpers: `scm_from_ptrdiff_t', `scm_to_ptrdiff_t'
+
+See "Integers".
+
+** Socket option `SO_REUSEPORT' now available from Scheme
+
+If supported on the platform, `SO_REUSEPORT' is now available from
+Scheme as well.  See "Network Sockets and Communication".
+
+** `current-language' in default environment
 
 Previously defined only in `(system base language)', `current-language'
 is now defined in the default environment, and is used to determine the
@@ -216,29 +308,12 @@ language for the REPL, and for `compile-and-load'.
 See "Parameters", for information on how to convert a fluid to a
 parameter.
 
-** New procedures to read all characters from a port
+** New `print' REPL option
-
-See "Line/Delimited" in the manual for documentation on `read-string'
- and `read-string!'.
-
-** New HTTP client procedures.
-
-See "Web Client" for documentation on the new `http-head', `http-post',
-`http-put', `http-delete', `http-trace', and `http-options' procedures,
-and also for more options to `http-get'.
-
-** New procedures for converting strings to and from bytevectors.
-
-See "Representing Strings as Bytes" for documention on the new `(ice-9
-iconv)' module and its `bytevector->string' and `string->bytevector'
-procedures.
-
-** New `print' REPL option.
 
 See "REPL Commands" in the manual for information on the new
 user-customizable REPL printer.
 
-** New variable: %site-ccache-dir.
+** New variable: %site-ccache-dir
     
 The "Installing Site Packages" and "Build Config" manual sections now
 refer to this variable to describe where users should install their
@@ -257,12 +332,18 @@ refer to this variable to describe where users should install their
 
 * Bug fixes
 
-** SRFI-37: Fix infinite loop when parsing optional-argument short options
+** Fix inexact number printer.
+   (http://bugs.gnu.org/13757)
+** Fix infinite loop when parsing optional-argument short options (SRFI-37).
    (http://bugs.gnu.org/13176)
-** web: Support non-GMT date headers in the HTTP client
+** web: Support non-GMT date headers in the HTTP client.
    (http://bugs.gnu.org/13544)
-** Avoid stack overflows with `par-map' and nested futures in general
+** web: support IP-literal (IPv6 address) in Host header.
+** Avoid stack overflows with `par-map' and nested futures in general.
    (http://bugs.gnu.org/13188)
+** Peek-char no longer consumes EOF.
+   (http://bugs.gnu.org/12216)
+** Avoid swallowing multiple EOFs in R6RS binary-input procedures.
 ** A fork when multiple threads are running will now print a warning.
 ** Allow for spurious wakeups from pthread_cond_wait.
    (http://bugs.gnu.org/10641)
@@ -270,7 +351,7 @@ refer to this variable to describe where users should install their
    (http://bugs.gnu.org/12202)
 ** Use chmod portably in (system base compile).
    (http://bugs.gnu.org/10474)
-** Fix response-body-port for responses without content-length.
+** Fix response-body-port for HTTP responses without content-length.
    (http://bugs.gnu.org/13857)
 ** Allow case-lambda expressions with no clauses.
    (http://bugs.gnu.org/9776)
@@ -297,9 +378,13 @@ refer to this variable to describe where users should install their
 ** Recognize the `x86_64.*-gnux32' triplet.
 ** Check whether a triplet's OS part specifies an ABI.
 ** Recognize mips64* as having 32-bit pointers by default.
+** Use portable sed constructs.
+   (http://bugs.gnu.org/14042)
 ** Remove language/glil/decompile-assembly.scm.
    (http://bugs.gnu.org/10622)
 ** Use O_BINARY in `copy-file', `load-objcode', `mkstemp'.
+** Use byte-oriented functions in `get-bytevector*'.
+** Fix abort when iconv swallows BOM from UTF-16 or UTF-32 stream.
 ** Fix compilation of functions with more than 255 local variables.
 ** Fix `getgroups' for when zero supplementary group IDs exist.
 ** Allow (define-macro name (lambda ...)).
@@ -309,16 +394,18 @@ refer to this variable to describe where users should install their
    (http://bugs.gnu.org/13485)
 ** Fix source annotation bug in psyntax 'expand-body'.
 ** Ecmascript: Fix conversion to boolean for non-numbers.
+** Use case-insensitive comparisons for encoding names.
+** Add missing cond-expand feature identifiers.
 ** A failure to find a module's file does not prevent future loading.
 ** Many (oop goops save) fixes.
 ** `http-get': don't shutdown write end of socket.
    (http://bugs.gnu.org/13095)
 ** Avoid signed integer overflow in scm_product.
-** http: read-response-body always returns bytevector or #f (not EOF in one case).
+** http: read-response-body always returns bytevector or #f, never EOF.
 ** web: Correctly detect "No route to host" conditions.
-** `system*': failure to execvp no longer leaks dangling processes
+** `system*': failure to execvp no longer leaks dangling processes.
    (http://bugs.gnu.org/13166)
-** More sensible case-lambda* dispatch
+** More sensible case-lambda* dispatch.
    (http://bugs.gnu.org/12929)
 ** Do not defer expansion of internal define-syntax forms.
    (http://bugs.gnu.org/13509)

README

@@ -72,7 +72,7 @@ Guile requires the following external packages:
     libltdl is used for loading extensions at run-time.  It is
     available from http://www.gnu.org/software/libtool/ .
 
-  - GNU libunistring
+  - GNU libunistring, at least version 0.9.3
 
     libunistring is used for Unicode string operations, such as the
     `utf*->string' procedures.  It is available from

THANKS

@@ -1,7 +1,9 @@
 Contributors since the last release:
 
+           Greg Benison
         Tristan Colgate-McFarlane
         Ludovic Courtès
+          Jason Earl
           Brian Gough
          Volker Grabsch
          Julian Graham
@@ -10,8 +12,11 @@ Contributors since the last release:
              No Itisnt
            Neil Jerram
         Chris K Jester-Young
+          David Kastrup
          Daniel Kraft
+         Daniel Krueger
            Noah Lavine
+         Daniel Llorens
         Gregory Marton
       Thien-Thi Nguyen
         Han-Wen Nienhuys
@@ -22,11 +27,14 @@ Contributors since the last release:
             Ken Raeburn
         Andreas Rottmann
           Kevin Ryde
+       Stefan I Tampe
              BT Templeton
+           Bake Timmons
          Mark H Weaver
           Göran Weinholt
            Ralf Wildenhues
            Andy Wingo
+            Eli Zaretskii
 
 Authors of free software libraries that have been included into Guile
 since the last release:
@@ -42,6 +50,7 @@ For fixes or providing information which led to a fix:
            Hans Åberg
           David Allouche
          Andrew Bagdanov
+          Lluís Batlle i Rossell
 	 Martin Baulig
         Fabrice Bauzac
         Sylvain Beucler
@@ -95,6 +104,7 @@ For fixes or providing information which led to a fix:
           David Jaquay
            Paul Jarc
           Steve Juranich
+         Nikita Karetnikov
           David Kastrup
         Richard Kim
           Bruce Korb
@@ -138,17 +148,20 @@ For fixes or providing information which led to a fix:
            Hugh Sasse
          Werner Scheinast
 	   Bill Schottstaedt
+            Jan Schukat
 	  Frank Schwidom
     John Steele Scott
          Thiemo Seufer
            Ivan Shcherbakov
           Scott Shedden
            Alex Shinn
+          Peter Simons
          Daniel Skarda
            Dale Smith
           Cesar Strauss
 	  Klaus Stehle
          Rainer Tammer
+	 Samuel Thibault
         Richard Todd
           Issac Trotts
            Greg Troxel
@@ -166,6 +179,7 @@ For fixes or providing information which led to a fix:
          Thomas Wawrzinek
         Mark H. Weaver
           Göran Weinholt
+       David A. Wheeler
            Ralf Wildenhues
             Jon Wilson
            Andy Wingo

configure.ac

@@ -734,8 +734,6 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
 #               has it as an inline for chsize)
 #   ioctl - not in mingw.
 #   gmtime_r - recent posix, not on old systems
-#   pipe - not in mingw
-#   _pipe - specific to mingw, taking 3 args
 #   readdir_r - recent posix, not on old systems
 #   readdir64_r - not available on HP-UX 11.11
 #   stat64 - SuS largefile stuff, not on old systems
@@ -751,10 +749,10 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
 #
 AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid		\
   fesetround ftime ftruncate fchown fchmod getcwd geteuid getsid	\
-  gettimeofday gmtime_r ioctl lstat mkdir mknod nice pipe _pipe		\
+  gettimeofday gmtime_r ioctl lstat mkdir mknod nice			\
-  readdir_r readdir64_r readlink rename rmdir select setegid seteuid	\
+  readdir_r readdir64_r readlink rename rmdir setegid seteuid		\
-  setlocale setpgid setsid sigaction siginterrupt stat64 strftime	\
+  setlocale setpgid setsid sigaction siginterrupt stat64		\
-  strptime symlink sync sysconf tcgetpgrp tcsetpgrp times uname waitpid	\
+  strptime symlink sync sysconf tcgetpgrp tcsetpgrp uname waitpid	\
   strdup system usleep atexit on_exit chown link fcntl ttyname getpwent	\
   getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp	\
   index bcopy memcpy rindex truncate unsetenv isblank _NSGetEnviron	\
@@ -1303,6 +1301,29 @@ if test $scm_cv_struct_linger = yes; then
            getsockopt and setsockopt system calls.])
 fi
 
+
+dnl Check for `struct timespec', for the sake of `gen-scmconfig'.  When
+dnl building Guile, we always have it, thanks to Gnulib; but scmconfig.h
+dnl must tell whether the system has it.
+dnl
+dnl On MinGW, struct timespec is in <pthread.h>.
+AC_MSG_CHECKING(for struct timespec)
+AC_CACHE_VAL(scm_cv_struct_timespec,
+	AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[
+#include <time.h>
+#if HAVE_PTHREAD_H
+#include <pthread.h>
+#endif]], [[struct timespec t;  t.tv_nsec = 100]])],
+          [scm_cv_struct_timespec="yes"],
+          [scm_cv_struct_timespec="no"]))
+AC_MSG_RESULT($scm_cv_struct_timespec)
+if test $scm_cv_struct_timespec = yes; then
+  dnl Don't call it `HAVE_STRUCT_TIMESPEC' because pthread-win32's
+  dnl <pthread.h> checks whether that macro is defined.
+  AC_DEFINE([HAVE_SYSTEM_STRUCT_TIMESPEC], 1,
+    [Define this if your system defines struct timespec via either <time.h> or <pthread.h>.])
+fi
+
 #--------------------------------------------------------------------
 #
 # Flags for thread support

doc/guile-api.alist

@@ -1359,7 +1359,6 @@
 (scm_array_copy_x (groups scm C) (scan-data T))
 (scm_array_dimensions (groups scm C) (scan-data T))
 (scm_array_equal_p (groups scm C) (scan-data T))
-(scm_array_fill_int (groups scm C) (scan-data T))
 (scm_array_fill_x (groups scm C) (scan-data T))
 (scm_array_for_each (groups scm C) (scan-data T))
 (scm_array_identity (groups scm C) (scan-data T))

doc/ref/api-binding.texi

@@ -218,9 +218,9 @@ variables.
 
 @lisp
 (letrec ((a 42)
-         (b (+ a 10)))
+         (b (+ a 10)))  ;; Illegal access
   (* a b))
-@result{} ;; Error: unbound variable: a
+;; The behavior of the expression above is unspecified
 
 (letrec* ((a 42)
           (b (+ a 10)))

doc/ref/api-compound.texi

@@ -2211,9 +2211,9 @@ different trade-offs.  Over the years, each ``standard'' has also come
 with its own new record interface, leading to a maze of record APIs.
 
 At the highest level is SRFI-9, a high-level record interface
-implemented by most Scheme implementations (@pxref{SRFI-9}).  It defines
+implemented by most Scheme implementations (@pxref{SRFI-9 Records}).  It
-a simple and efficient syntactic abstraction of record types and their
+defines a simple and efficient syntactic abstraction of record types and
-associated type predicate, fields, and field accessors.  SRFI-9 is
+their associated type predicate, fields, and field accessors.  SRFI-9 is
 suitable for most uses, and this is the recommended way to create record
 types in Guile.  Similar high-level record APIs include SRFI-35
 (@pxref{SRFI-35}) and R6RS records (@pxref{rnrs records syntactic}).
@@ -2451,7 +2451,7 @@ data type.  A @dfn{record} is an instance of a record type.
 
 Note that in many ways, this interface is too low-level for every-day
 use.  Most uses of records are better served by SRFI-9 records.
-@xref{SRFI-9}.
+@xref{SRFI-9 Records}.
 
 @deffn {Scheme Procedure} record? obj
 Return @code{#t} if @var{obj} is a record of any type and @code{#f}

doc/ref/api-control.texi

@@ -577,9 +577,58 @@ both.
 
 Before moving on, we should mention that if the handler of a prompt is a
 @code{lambda} expression, and the first argument isn't referenced, an abort to
-that prompt will not cause a continuation to be reified. This can be an
+that prompt will not cause a continuation to be reified.  This can be an
 important efficiency consideration to keep in mind.
 
+@cindex continuation, escape
+One example where this optimization matters is @dfn{escape
+continuations}.  Escape continuations are delimited continuations whose
+only use is to make a non-local exit---i.e., to escape from the current
+continuation.  Such continuations are invoked only once, and for this
+reason they are sometimes called @dfn{one-shot continuations}.  A common
+use of escape continuations is when throwing an exception
+(@pxref{Exceptions}).
+
+The constructs below are syntactic sugar atop prompts to simplify the
+use of escape continuations.
+
+@deffn {Scheme Procedure} call-with-escape-continuation proc
+@deffnx {Scheme Procedure} call/ec proc
+Call @var{proc} with an escape continuation.
+
+In the example below, the @var{return} continuation is used to escape
+the continuation of the call to @code{fold}.
+
+@lisp
+(use-modules (ice-9 control)
+             (srfi srfi-1))
+
+(define (prefix x lst)
+  ;; Return all the elements before the first occurrence
+  ;; of X in LST.
+  (call/ec
+    (lambda (return)
+      (fold (lambda (element prefix)
+              (if (equal? element x)
+                  (return (reverse prefix))  ; escape `fold'
+                  (cons element prefix)))
+            '()
+            lst))))
+
+(prefix 'a '(0 1 2 a 3 4 5))
+@result{} (0 1 2)
+@end lisp
+@end deffn
+
+@deffn {Scheme Syntax} let-escape-continuation k body @dots{}
+@deffnx {Scheme Syntax} let/ec k body @dots{}
+Bind @var{k} within @var{body} to an escape continuation.
+
+This is equivalent to
+@code{(call/ec (lambda (@var{k}) @var{body} @dots{}))}.
+@end deffn
+
+
 @node Shift and Reset
 @subsubsection Shift, Reset, and All That
 
@@ -987,6 +1036,11 @@ to avoid the risk of confusion with POSIX signals.
 This manual prefers to speak of throwing and catching exceptions, since
 this terminology matches the corresponding Guile primitives.
 
+The exception mechanism described in this section has connections with
+@dfn{delimited continuations} (@pxref{Prompts}).  In particular,
+throwing an exception is akin to invoking an @dfn{escape continuation}
+(@pxref{Prompt Primitives, @code{call/ec}}).
+
 
 @node Catch
 @subsubsection Catching Exceptions

doc/ref/api-data.texi

@@ -4222,7 +4222,7 @@ Unlike the rest of the procedures in this section, you have to load the
 (use-modules (ice-9 iconv))
 @end example
 
-@deffn string->bytevector string encoding [conversion-strategy]
+@deffn {Scheme Procedure} string->bytevector string encoding [conversion-strategy]
 Encode @var{string} as a sequence of bytes.
 
 The string will be encoded in the character set specified by the
@@ -4236,7 +4236,7 @@ bytevectors.  @xref{Ports}, for more on character encodings and
 conversion strategies.
 @end deffn
 
-@deffn bytevector->string bytevector encoding [conversion-strategy]
+@deffn {Scheme Procedure} bytevector->string bytevector encoding [conversion-strategy]
 Decode @var{bytevector} into a string.
 
 The bytes will be decoded from the character set by the @var{encoding}
@@ -4247,7 +4247,7 @@ argument to modify this behavior.  @xref{Ports}, for more on character
 encodings and conversion strategies.
 @end deffn
 
-@deffn call-with-output-encoded-string encoding proc [conversion-strategy]
+@deffn {Scheme Procedure} call-with-output-encoded-string encoding proc [conversion-strategy]
 Like @code{call-with-output-string}, but instead of returning a string,
 returns a encoding of the string according to @var{encoding}, as a
 bytevector.  This procedure can be more efficient than collecting a
@@ -4303,9 +4303,9 @@ If the C string is ill-formed, an error will be raised.
 
 Note that these functions should @emph{not} be used to convert C string
 constants, because there is no guarantee that the current locale will
-match that of the source code.  To convert C string constants, use
+match that of the execution character set, used for string and character
-@code{scm_from_latin1_string}, @code{scm_from_utf8_string} or
+constants.  Most modern C compilers use UTF-8 by default, so to convert
-@code{scm_from_utf32_string}.
+C string constants we recommend @code{scm_from_utf8_string}.
 @end deftypefn
 
 @deftypefn  {C Function} SCM scm_take_locale_string (char *str)
@@ -5375,15 +5375,15 @@ When you want to do more from C, you should convert between symbols
 and strings using @code{scm_symbol_to_string} and
 @code{scm_string_to_symbol} and work with the strings.
 
-@deftypefn {C Function} scm_from_latin1_symbol (const char *name)
+@deftypefn {C Function} SCM scm_from_latin1_symbol (const char *name)
-@deftypefnx {C Function} scm_from_utf8_symbol (const char *name)
+@deftypefnx {C Function} SCM scm_from_utf8_symbol (const char *name)
 Construct and return a Scheme symbol whose name is specified by the
 null-terminated C string @var{name}.  These are appropriate when
 the C string is hard-coded in the source code.
 @end deftypefn
 
-@deftypefn {C Function} scm_from_locale_symbol (const char *name)
+@deftypefn {C Function} SCM scm_from_locale_symbol (const char *name)
-@deftypefnx {C Function} scm_from_locale_symboln (const char *name, size_t len)
+@deftypefnx {C Function} SCM scm_from_locale_symboln (const char *name, size_t len)
 Construct and return a Scheme symbol whose name is specified by
 @var{name}.  For @code{scm_from_locale_symbol}, @var{name} must be null
 terminated; for @code{scm_from_locale_symboln} the length of @var{name} is
@@ -5391,8 +5391,9 @@ specified explicitly by @var{len}.
 
 Note that these functions should @emph{not} be used when @var{name} is a
 C string constant, because there is no guarantee that the current locale
-will match that of the source code.  In such cases, use
+will match that of the execution character set, used for string and
-@code{scm_from_latin1_symbol} or @code{scm_from_utf8_symbol}.
+character constants.  Most modern C compilers use UTF-8 by default, so
+in such cases we recommend @code{scm_from_utf8_symbol}.
 @end deftypefn
 
 @deftypefn  {C Function} SCM scm_take_locale_symbol (char *str)
@@ -5792,6 +5793,8 @@ For further details on @code{let-keywords}, @code{define*} and other
 facilities provided by the @code{(ice-9 optargs)} module, see
 @ref{Optional Arguments}.
 
+To handle keyword arguments from procedures implemented in C,
+use @code{scm_c_bind_keyword_arguments} (@pxref{Keyword Procedures}).
 
 @node Keyword Read Syntax
 @subsubsection Keyword Read Syntax
@@ -5883,8 +5886,9 @@ Equivalent to @code{scm_symbol_to_keyword (scm_from_locale_symbol
 
 Note that these functions should @emph{not} be used when @var{name} is a
 C string constant, because there is no guarantee that the current locale
-will match that of the source code.  In such cases, use
+will match that of the execution character set, used for string and
-@code{scm_from_latin1_keyword} or @code{scm_from_utf8_keyword}.
+character constants.  Most modern C compilers use UTF-8 by default, so
+in such cases we recommend @code{scm_from_utf8_keyword}.
 @end deftypefn
 
 @deftypefn {C Function} SCM scm_from_latin1_keyword (const char *name)
@@ -5894,6 +5898,70 @@ Equivalent to @code{scm_symbol_to_keyword (scm_from_latin1_symbol
 (@var{name}))}, respectively.
 @end deftypefn
 
+@deftypefn {C Function} void scm_c_bind_keyword_arguments (const char *subr, @
+                             SCM rest, scm_t_keyword_arguments_flags flags, @
+                             SCM keyword1, SCM *argp1, @
+                             @dots{}, @
+                             SCM keywordN, SCM *argpN, @
+                             @nicode{SCM_UNDEFINED})
+
+Extract the specified keyword arguments from @var{rest}, which is not
+modified.  If the keyword argument @var{keyword1} is present in
+@var{rest} with an associated value, that value is stored in the
+variable pointed to by @var{argp1}, otherwise the variable is left
+unchanged.  Similarly for the other keywords and argument pointers up to
+@var{keywordN} and @var{argpN}.  The argument list to
+@code{scm_c_bind_keyword_arguments} must be terminated by
+@code{SCM_UNDEFINED}.
+
+Note that since the variables pointed to by @var{argp1} through
+@var{argpN} are left unchanged if the associated keyword argument is not
+present, they should be initialized to their default values before
+calling @code{scm_c_bind_keyword_arguments}.  Alternatively, you can
+initialize them to @code{SCM_UNDEFINED} before the call, and then use
+@code{SCM_UNBNDP} after the call to see which ones were provided.
+
+If an unrecognized keyword argument is present in @var{rest} and
+@var{flags} does not contain @code{SCM_ALLOW_OTHER_KEYS}, or if
+non-keyword arguments are present and @var{flags} does not contain
+@code{SCM_ALLOW_NON_KEYWORD_ARGUMENTS}, an exception is raised.
+@var{subr} should be the name of the procedure receiving the keyword
+arguments, for purposes of error reporting.
+
+For example:
+
+@example
+SCM k_delimiter;
+SCM k_grammar;
+SCM sym_infix;
+
+SCM my_string_join (SCM strings, SCM rest)
+@{
+  SCM delimiter = SCM_UNDEFINED;
+  SCM grammar   = sym_infix;
+
+  scm_c_bind_keyword_arguments ("my-string-join", rest, 0,
+                                k_delimiter, &delimiter,
+                                k_grammar, &grammar,
+                                SCM_UNDEFINED);
+
+  if (SCM_UNBNDP (delimiter))
+    delimiter = scm_from_utf8_string (" ");
+
+  return scm_string_join (strings, delimiter, grammar);
+@}
+
+void my_init ()
+@{
+  k_delimiter = scm_from_utf8_keyword ("delimiter");
+  k_grammar   = scm_from_utf8_keyword ("grammar");
+  sym_infix   = scm_from_utf8_symbol  ("infix");
+  scm_c_define_gsubr ("my-string-join", 1, 0, 1, my_string_join);
+@}
+@end example
+@end deftypefn
+
+
 @node Other Types
 @subsection ``Functionality-Centric'' Data Types
 

doc/ref/api-evaluation.texi

@@ -991,17 +991,19 @@ three arguments.
 @cindex source file encoding
 @cindex primitive-load
 @cindex load
-Scheme source code files are usually encoded in ASCII, but, the
+Scheme source code files are usually encoded in ASCII or UTF-8, but the
-built-in reader can interpret other character encodings.  The
+built-in reader can interpret other character encodings as well.  When
-procedure @code{primitive-load}, and by extension the functions that
+Guile loads Scheme source code, it uses the @code{file-encoding}
-call it, such as @code{load}, first scan the top 500 characters of the
+procedure (described below) to try to guess the encoding of the file.
-file for a coding declaration.
+In the absence of any hints, UTF-8 is assumed.  One way to provide a
+hint about the encoding of a source file is to place a coding
+declaration in the top 500 characters of the file.
 
 A coding declaration has the form @code{coding: XXXXXX}, where
 @code{XXXXXX} is the name of a character encoding in which the source
 code file has been encoded.  The coding declaration must appear in a
-scheme comment.  It can either be a semicolon-initiated comment or a block
+scheme comment.  It can either be a semicolon-initiated comment, or the
-@code{#!} comment.
+first block @code{#!} comment in the file.
 
 The name of the character encoding in the coding declaration is
 typically lower case and containing only letters, numbers, and hyphens,
@@ -1050,15 +1052,21 @@ the port's character encoding should be set to the encoding returned
 by @code{file-encoding}, if any, again by using
 @code{set-port-encoding!}.  Then the code can be read as normal.
 
+Alternatively, one can use the @code{#:guess-encoding} keyword argument
+of @code{open-file} and related procedures.  @xref{File Ports}.
+
 @deffn {Scheme Procedure} file-encoding port
 @deffnx {C Function} scm_file_encoding (port)
-Scan the port for an Emacs-like character coding declaration near the
+Attempt to scan the first few hundred bytes from the @var{port} for
-top of the contents of a port with random-accessible contents
+hints about its character encoding.  Return a string containing the
-(@pxref{Recognize Coding, how Emacs recognizes file encoding,, emacs,
+encoding name or @code{#f} if the encoding cannot be determined.  The
-The GNU Emacs Reference Manual}).  The coding declaration is of the form
+port is rewound.
-@code{coding: XXXXX} and must appear in a Scheme comment.  Return a
+
-string containing the character encoding of the file if a declaration
+Currently, the only supported method is to look for an Emacs-like
-was found, or @code{#f} otherwise.  The port is rewound.
+character coding declaration (@pxref{Recognize Coding, how Emacs
+recognizes file encoding,, emacs, The GNU Emacs Reference Manual}).  The
+coding declaration is of the form @code{coding: XXXXX} and must appear
+in a Scheme comment.  Additional heuristics may be added in the future.
 @end deffn
 
 

doc/ref/api-io.texi

@@ -1,7 +1,7 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
 @c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2009,
-@c   2010, 2011  Free Software Foundation, Inc.
+@c   2010, 2011, 2013  Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
 @node Input and Output
@@ -19,6 +19,7 @@
 * Port Types::                  Types of port and how to make them.
 * R6RS I/O Ports::              The R6RS port API.
 * I/O Extensions::              Using and extending ports in C.
+* BOM Handling::                Handling of Unicode byte order marks.
 @end menu
 
 
@@ -842,7 +843,10 @@ Most systems have limits on how many files can be open, so it's
 strongly recommended that file ports be closed explicitly when no
 longer required (@pxref{Ports}).
 
-@deffn {Scheme Procedure} open-file filename mode
+@deffn {Scheme Procedure} open-file filename mode @
+                          [#:guess-encoding=#f] [#:encoding=#f]
+@deffnx {C Function} scm_open_file_with_encoding @
+                     (filename, mode, guess_encoding, encoding)
 @deffnx {C Function} scm_open_file (filename, mode)
 Open the file whose name is @var{filename}, and return a port
 representing that file.  The attributes of the port are
@@ -884,8 +888,8 @@ Use binary mode, ensuring that each byte in the file will be read as one
 Scheme character.
 
 To provide this property, the file will be opened with the 8-bit
-character encoding "ISO-8859-1", ignoring any coding declaration or port
+character encoding "ISO-8859-1", ignoring the default port encoding.
-encoding.  @xref{Ports}, for more information on port encodings.
+@xref{Ports}, for more information on port encodings.
 
 Note that while it is possible to read and write binary data as
 characters or strings, it is usually better to treat bytes as octets,
@@ -899,15 +903,33 @@ to the underlying @code{open} call.  Still, the flag is generally useful
 because of its port encoding ramifications.
 @end table
 
-If a file cannot be opened with the access
+Unless binary mode is requested, the character encoding of the new port
-requested, @code{open-file} throws an exception.
+is determined as follows: First, if @var{guess-encoding} is true, the
+@code{file-encoding} procedure is used to guess the encoding of the file
+(@pxref{Character Encoding of Source Files}).  If @var{guess-encoding}
+is false or if @code{file-encoding} fails, @var{encoding} is used unless
+it is also false.  As a last resort, the default port encoding is used.
+@xref{Ports}, for more information on port encodings.  It is an error to
+pass a non-false @var{guess-encoding} or @var{encoding} if binary mode
+is requested.
 
-When the file is opened, this procedure will scan for a coding
+If a file cannot be opened with the access requested, @code{open-file}
-declaration (@pxref{Character Encoding of Source Files}). If a coding
+throws an exception.
-declaration is found, it will be used to interpret the file.  Otherwise,
+
-the port's encoding will be used.  To suppress this behavior, open the
+When the file is opened, its encoding is set to the current
-file in binary mode and then set the port encoding explicitly using
+@code{%default-port-encoding}, unless the @code{b} flag was supplied.
-@code{set-port-encoding!}.
+Sometimes it is desirable to honor Emacs-style coding declarations in
+files@footnote{Guile 2.0.0 to 2.0.7 would do this by default.  This
+behavior was deemed inappropriate and disabled starting from Guile
+2.0.8.}.  When that is the case, the @code{file-encoding} procedure can
+be used as follows (@pxref{Character Encoding of Source Files,
+@code{file-encoding}}):
+
+@example
+(let* ((port     (open-input-file file))
+       (encoding (file-encoding port)))
+  (set-port-encoding! port (or encoding (port-encoding port))))
+@end example
 
 In theory we could create read/write ports which were buffered
 in one direction only.  However this isn't included in the
@@ -915,23 +937,40 @@ current interfaces.
 @end deffn
 
 @rnindex open-input-file
-@deffn {Scheme Procedure} open-input-file filename
+@deffn {Scheme Procedure} open-input-file filename @
-Open @var{filename} for input.  Equivalent to
+       [#:guess-encoding=#f] [#:encoding=#f] [#:binary=#f]
+
+Open @var{filename} for input.  If @var{binary} is true, open the port
+in binary mode, otherwise use text mode.  @var{encoding} and
+@var{guess-encoding} determine the character encoding as described above
+for @code{open-file}.  Equivalent to
 @lisp
-(open-file @var{filename} "r")
+(open-file @var{filename}
+           (if @var{binary} "rb" "r")
+           #:guess-encoding @var{guess-encoding}
+           #:encoding @var{encoding})
 @end lisp
 @end deffn
 
 @rnindex open-output-file
-@deffn {Scheme Procedure} open-output-file filename
+@deffn {Scheme Procedure} open-output-file filename @
-Open @var{filename} for output.  Equivalent to
+       [#:encoding=#f] [#:binary=#f]
+
+Open @var{filename} for output.  If @var{binary} is true, open the port
+in binary mode, otherwise use text mode.  @var{encoding} specifies the
+character encoding as described above for @code{open-file}.  Equivalent
+to
 @lisp
-(open-file @var{filename} "w")
+(open-file @var{filename}
+           (if @var{binary} "wb" "w")
+           #:encoding @var{encoding})
 @end lisp
 @end deffn
 
-@deffn {Scheme Procedure} call-with-input-file filename proc
+@deffn {Scheme Procedure} call-with-input-file filename proc @
-@deffnx {Scheme Procedure} call-with-output-file filename proc
+        [#:guess-encoding=#f] [#:encoding=#f] [#:binary=#f]
+@deffnx {Scheme Procedure} call-with-output-file filename proc @
+        [#:encoding=#f] [#:binary=#f]
 @rnindex call-with-input-file
 @rnindex call-with-output-file
 Open @var{filename} for input or output, and call @code{(@var{proc}
@@ -946,9 +985,12 @@ closed automatically, though it will be garbage collected in the usual
 way if not otherwise referenced.
 @end deffn
 
-@deffn {Scheme Procedure} with-input-from-file filename thunk
+@deffn {Scheme Procedure} with-input-from-file filename thunk @
-@deffnx {Scheme Procedure} with-output-to-file filename thunk
+        [#:guess-encoding=#f] [#:encoding=#f] [#:binary=#f]
-@deffnx {Scheme Procedure} with-error-to-file filename thunk
+@deffnx {Scheme Procedure} with-output-to-file filename thunk @
+        [#:encoding=#f] [#:binary=#f]
+@deffnx {Scheme Procedure} with-error-to-file filename thunk @
+        [#:encoding=#f] [#:binary=#f]
 @rnindex with-input-from-file
 @rnindex with-output-to-file
 Open @var{filename} and call @code{(@var{thunk})} with the new port
@@ -1214,9 +1256,10 @@ possible.
 * R6RS Textual Output::         Textual output.
 @end menu
 
-A subset of the @code{(rnrs io ports)} module is provided by the
+A subset of the @code{(rnrs io ports)} module, plus one non-standard
-@code{(ice-9 binary-ports)} module.  It contains binary input/output
+procedure @code{unget-bytevector} (@pxref{R6RS Binary Input}), is
-procedures and does not rely on R6RS support.
+provided by the @code{(ice-9 binary-ports)} module.  It contains binary
+input/output procedures and does not rely on R6RS support.
 
 @node R6RS File Names
 @subsubsection File Names
@@ -1833,9 +1876,10 @@ actually read or the end-of-file object.
 
 @deffn {Scheme Procedure} get-bytevector-some port
 @deffnx {C Function} scm_get_bytevector_some (port)
-Read from @var{port}, blocking as necessary, until data are available or
+Read from @var{port}, blocking as necessary, until bytes are available
-and end-of-file is reached.  Return either a new bytevector containing
+or an end-of-file is reached.  Return either the end-of-file object or a
-the data read or the end-of-file object.
+new bytevector containing some of the available bytes (at least one),
+and update the port position to point just past these bytes.
 @end deffn
 
 @deffn {Scheme Procedure} get-bytevector-all port
@@ -1845,6 +1889,18 @@ reached.  Return either a new bytevector containing the data read or the
 end-of-file object (if no data were available).
 @end deffn
 
+The @code{(ice-9 binary-ports)} module provides the following procedure
+as an extension to @code{(rnrs io ports)}:
+
+@deffn {Scheme Procedure} unget-bytevector port bv [start [count]]
+@deffnx {C Function} scm_unget_bytevector (port, bv, start, count)
+Place the contents of @var{bv} in @var{port}, optionally starting at
+index @var{start} and limiting to @var{count} octets, so that its bytes
+will be read from left-to-right as the next bytes from @var{port} during
+subsequent read operations.  If called multiple times, the unread bytes
+will be read again in last-in first-out order.
+@end deffn
+
 @node R6RS Textual Input
 @subsubsection Textual Input
 
@@ -2372,6 +2428,84 @@ Set using
 
 @end table
 
+@node BOM Handling
+@subsection Handling of Unicode byte order marks.
+@cindex BOM
+@cindex byte order mark
+
+This section documents the finer points of Guile's handling of Unicode
+byte order marks (BOMs).  A byte order mark (U+FEFF) is typically found
+at the start of a UTF-16 or UTF-32 stream, to allow readers to reliably
+determine the byte order.  Occasionally, a BOM is found at the start of
+a UTF-8 stream, but this is much less common and not generally
+recommended.
+
+Guile attempts to handle BOMs automatically, and in accordance with the
+recommendations of the Unicode Standard, when the port encoding is set
+to @code{UTF-8}, @code{UTF-16}, or @code{UTF-32}.  In brief, Guile
+automatically writes a BOM at the start of a UTF-16 or UTF-32 stream,
+and automatically consumes one from the start of a UTF-8, UTF-16, or
+UTF-32 stream.
+
+As specified in the Unicode Standard, a BOM is only handled specially at
+the start of a stream, and only if the port encoding is set to
+@code{UTF-8}, @code{UTF-16} or @code{UTF-32}.  If the port encoding is
+set to @code{UTF-16BE}, @code{UTF-16LE}, @code{UTF-32BE}, or
+@code{UTF-32LE}, then BOMs are @emph{not} handled specially, and none of
+the special handling described in this section applies.
+
+@itemize @bullet
+@item
+To ensure that Guile will properly detect the byte order of a UTF-16 or
+UTF-32 stream, you must perform a textual read before any writes, seeks,
+or binary I/O.  Guile will not attempt to read a BOM unless a read is
+explicitly requested at the start of the stream.
+
+@item
+If a textual write is performed before the first read, then an arbitrary
+byte order will be chosen.  Currently, big endian is the default on all
+platforms, but that may change in the future.  If you wish to explicitly
+control the byte order of an output stream, set the port encoding to
+@code{UTF-16BE}, @code{UTF-16LE}, @code{UTF-32BE}, or @code{UTF-32LE},
+and explicitly write a BOM (@code{#\xFEFF}) if desired.
+
+@item
+If @code{set-port-encoding!} is called in the middle of a stream, Guile
+treats this as a new logical ``start of stream'' for purposes of BOM
+handling, and will forget about any BOMs that had previously been seen.
+Therefore, it may choose a different byte order than had been used
+previously.  This is intended to support multiple logical text streams
+embedded within a larger binary stream.
+
+@item
+Binary I/O operations are not guaranteed to update Guile's notion of
+whether the port is at the ``start of the stream'', nor are they
+guaranteed to produce or consume BOMs.
+
+@item
+For ports that support seeking (e.g. normal files), the input and output
+streams are considered linked: if the user reads first, then a BOM will
+be consumed (if appropriate), but later writes will @emph{not} produce a
+BOM.  Similarly, if the user writes first, then later reads will
+@emph{not} consume a BOM.
+
+@item
+For ports that do not support seeking (e.g. pipes, sockets, and
+terminals), the input and output streams are considered
+@emph{independent} for purposes of BOM handling: the first read will
+consume a BOM (if appropriate), and the first write will @emph{also}
+produce a BOM (if appropriate).  However, the input and output streams
+will always use the same byte order.
+
+@item
+Seeks to the beginning of a file will set the ``start of stream'' flags.
+Therefore, a subsequent textual read or write will consume or produce a
+BOM.  However, unlike @code{set-port-encoding!}, if a byte order had
+already been chosen for the port, it will remain in effect after a seek,
+and cannot be changed by the presence of a BOM.  Seeks anywhere other
+than the beginning of a file clear the ``start of stream'' flags.
+@end itemize
+
 @c Local Variables:
 @c TeX-master: "guile.texi"
 @c End:

doc/ref/api-modules.texi

@@ -50,7 +50,6 @@ be used for interacting with the module system.
 * Variables::                   First-class variables.
 * Module System Reflection::    First-class modules.
 * Accessing Modules from C::    How to work with modules with C code.
-* Included Guile Modules::      Which modules come with Guile?
 * provide and require::         The SLIB feature mechanism.
 * Environments::                R5RS top-level environments.
 @end menu
@@ -111,8 +110,7 @@ interface is the one accessed.  For example:
 
 Here, the interface specification is @code{(ice-9 popen)}, and the
 result is that the current module now has access to @code{open-pipe},
-@code{close-pipe}, @code{open-input-pipe}, and so on (@pxref{Included
+@code{close-pipe}, @code{open-input-pipe}, and so on (@pxref{Pipes}).
-Guile Modules}).
 
 Note in the previous example that if the current module had already
 defined @code{open-pipe}, that definition would be overwritten by the
@@ -1062,124 +1060,6 @@ of the current module.  The list of names is terminated by
 @end deftypefn
 
 
-@node Included Guile Modules
-@subsection Included Guile Modules
-
-Some modules are included in the Guile distribution; here are references
-to the entries in this manual which describe them in more detail:
-
-@table @strong
-@item boot-9
-boot-9 is Guile's initialization module, and it is always loaded when
-Guile starts up.
-
-@item (ice-9 expect)
-Actions based on matching input from a port (@pxref{Expect}).
-
-@item (ice-9 format)
-Formatted output in the style of Common Lisp (@pxref{Formatted
-Output}).
-
-@item (ice-9 ftw)
-File tree walker (@pxref{File Tree Walk}).
-
-@item (ice-9 getopt-long)
-Command line option processing (@pxref{getopt-long}).
-
-@item (ice-9 history)
-Refer to previous interactive expressions (@pxref{Value History}).
-
-@item (ice-9 popen)
-Pipes to and from child processes (@pxref{Pipes}).
-
-@item (ice-9 pretty-print)
-Nicely formatted output of Scheme expressions and objects
-(@pxref{Pretty Printing}).
-
-@item (ice-9 q)
-First-in first-out queues (@pxref{Queues}).
-
-@item (ice-9 rdelim)
-Line- and character-delimited input (@pxref{Line/Delimited}).
-
-@item (ice-9 readline)
-@code{readline} interactive command line editing (@pxref{Readline
-Support}).
-
-@item (ice-9 receive)
-Multiple-value handling with @code{receive} (@pxref{Multiple Values}).
-
-@item (ice-9 regex)
-Regular expression matching (@pxref{Regular Expressions}).
-
-@item (ice-9 rw)
-Block string input/output (@pxref{Block Reading and Writing}).
-
-@item (ice-9 streams)
-Sequence of values calculated on-demand (@pxref{Streams}).
-
-@item (ice-9 syncase)
-R5RS @code{syntax-rules} macro system (@pxref{Syntax Rules}).
-
-@item (ice-9 threads)
-Guile's support for multi threaded execution (@pxref{Scheduling}).
-
-@item (ice-9 documentation)
-Online documentation (REFFIXME).
-
-@item (srfi srfi-1)
-A library providing a lot of useful list and pair processing
-procedures (@pxref{SRFI-1}).
-
-@item (srfi srfi-2)
-Support for @code{and-let*} (@pxref{SRFI-2}).
-
-@item (srfi srfi-4)
-Support for homogeneous numeric vectors (@pxref{SRFI-4}).
-
-@item (srfi srfi-6)
-Support for some additional string port procedures (@pxref{SRFI-6}).
-
-@item (srfi srfi-8)
-Multiple-value handling with @code{receive} (@pxref{SRFI-8}).
-
-@item (srfi srfi-9)
-Record definition with @code{define-record-type} (@pxref{SRFI-9}).
-
-@item (srfi srfi-10)
-Read hash extension @code{#,()} (@pxref{SRFI-10}).
-
-@item (srfi srfi-11)
-Multiple-value handling with @code{let-values} and @code{let*-values}
-(@pxref{SRFI-11}).
-
-@item (srfi srfi-13)
-String library (@pxref{SRFI-13}).
-
-@item (srfi srfi-14)
-Character-set library (@pxref{SRFI-14}).
-
-@item (srfi srfi-16)
-@code{case-lambda} procedures of variable arity (@pxref{SRFI-16}).
-
-@item (srfi srfi-17)
-Getter-with-setter support (@pxref{SRFI-17}).
-
-@item (srfi srfi-19)
-Time/Date library (@pxref{SRFI-19}).
-
-@item (srfi srfi-26)
-Convenient syntax for partial application (@pxref{SRFI-26})
-
-@item (srfi srfi-31)
-@code{rec} convenient recursive expressions (@pxref{SRFI-31})
-
-@item (ice-9 slib)
-This module contains hooks for using Aubrey Jaffer's portable Scheme
-library SLIB from Guile (@pxref{SLIB}).
-@end table
-
-
 @node provide and require
 @subsection provide and require
 

doc/ref/api-procedures.texi

@@ -575,7 +575,8 @@ with @code{lambda} (@pxref{Lambda}).
 @example
 @group
 <case-lambda>
-   --> (case-lambda <case-lambda-clause>)
+   --> (case-lambda <case-lambda-clause>*)
+   --> (case-lambda <docstring> <case-lambda-clause>*)
 <case-lambda-clause>
    --> (<formals> <definition-or-command>*)
 <formals>
@@ -590,6 +591,7 @@ Rest lists can be useful with @code{case-lambda}:
 @lisp
 (define plus
   (case-lambda
+    "Return the sum of all arguments."
     (() 0)
     ((a) a)
     ((a b) (+ a b))

doc/ref/guile-invoke.texi

@@ -208,6 +208,35 @@ Treat the auto-compilation cache as invalid, forcing recompilation.
 @item --no-auto-compile
 Disable automatic source file compilation.
 
+@vnew{2.0.8}
+
+@item --language=@var{lang}
+For the remainder of the command line arguments, assume that files
+mentioned with @code{-l} and expressions passed with @code{-c} are
+written in @var{lang}.  @var{lang} must be the name of one of the
+languages supported by the compiler (@pxref{Compiler Tower}).  When run
+interactively, set the REPL's language to @var{lang} (@pxref{Using Guile
+Interactively}).
+
+The default language is @code{scheme}; other interesting values include
+@code{elisp} (for Emacs Lisp), and @code{ecmascript}.
+
+The example below shows the evaluation of expressions in Scheme, Emacs
+Lisp, and ECMAScript:
+
+@example
+guile -c "(apply + '(1 2))"
+guile --language=elisp -c "(= (funcall (symbol-function '+) 1 2) 3)"
+guile --language=ecmascript -c '(function (x) @{ return x * x; @})(2);'
+@end example
+
+To load a file written in Scheme and one written in Emacs Lisp, and then
+start a Scheme REPL, type:
+
+@example
+guile -l foo.scm --language=elisp -l foo.el --language=scheme
+@end example
+
 @vnew{2.0}
 
 @item -h@r{, }--help

doc/ref/posix.texi

@@ -806,9 +806,10 @@ The return value is unspecified.
 @deffn {Scheme Procedure} sendfile out in count [offset]
 @deffnx {C Function} scm_sendfile (out, in, count, offset)
 Send @var{count} bytes from @var{in} to @var{out}, both of which
-are either open file ports or file descriptors.  When
+must be either open file ports or file descriptors.  When
 @var{offset} is omitted, start reading from @var{in}'s current
-position; otherwise, start reading at @var{offset}.
+position; otherwise, start reading at @var{offset}.  Return
+the number of bytes actually sent.
 
 When @var{in} is a port, it is often preferable to specify @var{offset},
 because @var{in}'s offset as a port may be different from the offset of
@@ -824,6 +825,12 @@ In some cases, the @code{sendfile} libc function may return
 @code{EINVAL} or @code{ENOSYS}.  In that case, Guile's @code{sendfile}
 procedure automatically falls back to doing a series of @code{read} and
 @code{write} calls.
+
+In other cases, the libc function may send fewer bytes than
+@var{count}---for instance because @var{out} is a slow or limited
+device, such as a pipe.  When that happens, Guile's @code{sendfile}
+automatically retries until exactly @var{count} bytes were sent or an
+error occurs.
 @end deffn
 
 @findex rename
@@ -1009,6 +1016,43 @@ Return @code{#t} if the file named @var{filename} exists, @code{#f} if
 not.
 @end deffn
 
+@cindex file name separator
+@cindex absolute file name
+
+Many operating systems, such as GNU, use @code{/} (forward slash) to
+separate the components of a file name; any file name starting with
+@code{/} is considered an @dfn{absolute file name}.  These conventions
+are specified by the POSIX Base Definitions, which refer to conforming
+file names as ``pathnames''.  Some operating systems use a different
+convention; in particular, Windows uses @code{\} (backslash) as the file
+name separator, and also has the notion of @dfn{volume names} like
+@code{C:\} for absolute file names.  The following procedures and
+variables provide support for portable file name manipulations.
+
+@deffn {Scheme Procedure} system-file-name-convention
+Return either @code{posix} or @code{windows}, depending on
+what kind of system this Guile is running on.
+@end deffn
+
+@deffn {Scheme Procedure} file-name-separator? c
+Return true if character @var{c} is a file name separator on the host
+platform.
+@end deffn
+
+@deffn {Scheme Procedure} absolute-file-name? file-name
+Return true if @var{file-name} denotes an absolute file name on the host
+platform.
+@end deffn
+
+@defvr {Scheme Variable} file-name-separator-string
+The preferred file name separator.
+
+Note that on MinGW builds for Windows, both @code{/} and @code{\} are
+valid separators.  Thus, programs should not assume that
+@code{file-name-separator-string} is the @emph{only} file name
+separator---e.g., when extracting the components of a file name.
+@end defvr
+
 
 @node User Information
 @subsection User Information

doc/ref/r6rs.texi

@@ -826,11 +826,11 @@ This form is identical to the one provided by Guile's core library.
 @node R6RS Records
 @subsubsection R6RS Records
 
-The manual sections below describe Guile's implementation of R6RS 
+The manual sections below describe Guile's implementation of R6RS
 records, which provide support for user-defined data types.  The R6RS
 records API provides a superset of the features provided by Guile's
 ``native'' records, as well as those of the SRFI-9 records API;
-@xref{Records}, and @ref{SRFI-9}, for a description of those
+@xref{Records}, and @ref{SRFI-9 Records}, for a description of those
 interfaces.
 
 As with SRFI-9 and Guile's native records, R6RS records are constructed

doc/release.org

@@ -1,5 +1,6 @@
 #+TITLE: Release Process for GNU Guile 2.0
 #+AUTHOR: Ludovic Courtès
+#+STARTUP: content
 #+EMAIL: ludo@gnu.org
 
 This document describes the typical release process for Guile 2.0.
@@ -53,7 +54,6 @@ If you're still in a good mood, you may also want to check on porter
 boxes for other OSes.  The GNU/Hurd people have [[http://www.gnu.org/software/hurd/public_hurd_boxen.html][porter boxes]], and so do
 the [[http://www.opencsw.org/standards/build_farm][OpenCSW Solaris Team]] and the [[http://lists.gnu.org/archive/html/autoconf/2012-11/msg00039.html][Snakebite]] project.
 
-
 *** Post a pre-release announcement to `platform-testers@gnu.org'
 
 Send a link to [[http://hydra.nixos.org/job/gnu/guile-2-0/tarball/latest/download-by-type/file/source-dist][the latest tarball]].  This will allow readers to test on
@@ -87,15 +87,14 @@ The tag *must* be `v2.0.X'.  For the sake of consistency, always use
 
 Normally nobody committed in the meantime.  ;-)
 
-** Run "make dist"
+** Run "make distcheck"
 
 This should trigger an `autoreconf', as `build-aux/git-version-gen'
-notices the new tag.  After "make dist", double-check that `./configure
+notices the new tag.  Make sure you have configured with all options
---version' reports the new version number.
+enabled (Readline, --enable-deprecated, etc.)
 
-The reason for running "make dist" instead of "make distcheck" is that
+After "make distcheck", double-check that `./configure --version'
-it's much faster and any distribution issues should have been caught by
+reports the new version number.
-Hydra already.
 
 ** Upload
 
@@ -146,7 +145,7 @@ Use `build-aux/gendocs', add to the manual/ directory of the web site.
   $ build-aux/announce-gen --release-type=stable --package-name=guile \
       --previous-version=2.0.1 --current-version=2.0.2 \
       --gpg-key-id=MY-KEY --url-directory=ftp://ftp.gnu.org/gnu/guile \
-      --bootstrap-tools=autoconf,automake,libtool,gnulib \
+      --bootstrap-tools=autoconf,automake,libtool,gnulib,makeinfo \
       --gnulib-version=$( cd ~/src/gnulib ; git describe )
 
 The subject must be "GNU Guile 2.0.X released".  The text should remain
@@ -174,7 +173,7 @@ more informal, with a link to the email announcement for details.
 
 
 
-Copyright © 2011, 2012 Free Software Foundation, Inc.
+Copyright © 2011, 2012, 2013 Free Software Foundation, Inc.
 
   Copying and distribution of this file, with or without modification,
   are permitted in any medium without royalty provided the copyright

lib/Makefile.am

@@ -21,7 +21,7 @@
 # the same distribution terms as the rest of that program.
 #
 # Generated by gnulib-tool.
-# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp fstat full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe-posix pipe2 poll putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc verify vsnprintf warnings wchar
+# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp fstat full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe-posix pipe2 poll putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc verify vsnprintf warnings wchar
 
 AUTOMAKE_OPTIONS = 1.5 gnits subdir-objects
 

libguile/Makefile.am

@@ -1,6 +1,7 @@
 ## Process this file with Automake to create Makefile.in
 ##
-##  	Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+##   Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007,
+##     2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
 ##
 ##   This file is part of GUILE.
 ##
@@ -463,7 +464,7 @@ noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c		\
                  srfi-14.i.c					\
                  quicksort.i.c                                  \
                  win32-uname.h					\
-		 private-gc.h private-options.h
+		 private-gc.h private-options.h ports-internal.h
 
 # vm instructions
 noinst_HEADERS += vm-engine.c vm-i-system.c vm-i-scheme.c vm-i-loader.c

libguile/array-map.c

@@ -1,4 +1,5 @@
-/* Copyright (C) 1996,1998,2000,2001,2004,2005, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 1996, 1998, 2000, 2001, 2004, 2005, 2006, 2008, 2009,
+ *   2010, 2011, 2012, 2013 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
@@ -317,6 +318,23 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
     }
 }
 
+static int
+rafill (SCM dst, SCM fill)
+{
+  long n = (SCM_I_ARRAY_DIMS (dst)->ubnd - SCM_I_ARRAY_DIMS (dst)->lbnd + 1);
+  scm_t_array_handle h;
+  size_t i;
+  ssize_t inc;
+  scm_array_get_handle (SCM_I_ARRAY_V (dst), &h);
+  i = h.base + h.dims[0].lbnd + SCM_I_ARRAY_BASE (dst)*h.dims[0].inc;
+  inc = SCM_I_ARRAY_DIMS (dst)->inc * h.dims[0].inc;
+
+  for (; n-- > 0; i += inc)
+    h.impl->vset (&h, i, fill);
+
+  scm_array_handle_release (&h);
+  return 1;
+}
 
 SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0,
 	    (SCM ra, SCM fill),
@@ -324,47 +342,35 @@ SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0,
 	    "returned is unspecified.")
 #define FUNC_NAME s_scm_array_fill_x
 {
-  scm_ramapc (scm_array_fill_int, fill, ra, SCM_EOL, FUNC_NAME);
+  scm_ramapc (rafill, fill, ra, SCM_EOL, FUNC_NAME);
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
 
-/* to be used as cproc in scm_ramapc to fill an array dimension with
-   "fill". */
-int 
-scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED)
-#define FUNC_NAME s_scm_array_fill_x
-{
-  unsigned long i;
-  unsigned long n = SCM_I_ARRAY_DIMS (ra)->ubnd - SCM_I_ARRAY_DIMS (ra)->lbnd + 1;
-  long inc = SCM_I_ARRAY_DIMS (ra)->inc;
-  unsigned long base = SCM_I_ARRAY_BASE (ra);
 
-  ra = SCM_I_ARRAY_V (ra);
+static int
-
-  for (i = base; n--; i += inc)
-    GVSET (ra, i, fill);
-
-  return 1;
-}
-#undef FUNC_NAME
-
-
-
-static int 
 racp (SCM src, SCM dst)
 {
   long n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1);
-  long inc_d, inc_s = SCM_I_ARRAY_DIMS (src)->inc;
+  scm_t_array_handle h_s, h_d;
-  unsigned long i_d, i_s = SCM_I_ARRAY_BASE (src);
+  size_t i_s, i_d;
+  ssize_t inc_s, inc_d;
+
   dst = SCM_CAR (dst);
-  inc_d = SCM_I_ARRAY_DIMS (dst)->inc;
+  scm_array_get_handle (SCM_I_ARRAY_V (src), &h_s);
-  i_d = SCM_I_ARRAY_BASE (dst);
+  scm_array_get_handle (SCM_I_ARRAY_V (dst), &h_d);
-  src = SCM_I_ARRAY_V (src);
+
-  dst = SCM_I_ARRAY_V (dst);
+  i_s = h_s.base + h_s.dims[0].lbnd + SCM_I_ARRAY_BASE (src) * h_s.dims[0].inc;
+  i_d = h_d.base + h_d.dims[0].lbnd + SCM_I_ARRAY_BASE (dst) * h_d.dims[0].inc;
+  inc_s = SCM_I_ARRAY_DIMS (src)->inc * h_s.dims[0].inc;
+  inc_d = SCM_I_ARRAY_DIMS (dst)->inc * h_d.dims[0].inc;
 
   for (; n-- > 0; i_s += inc_s, i_d += inc_d)
-    GVSET (dst, i_d, GVREF (src, i_s));
+    h_d.impl->vset (&h_d, i_d, h_s.impl->vref (&h_s, i_s));
+
+  scm_array_handle_release (&h_d);
+  scm_array_handle_release (&h_s);
+
   return 1;
 }
 
@@ -385,8 +391,28 @@ SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
 }
 #undef FUNC_NAME
 
-/* Functions callable by ARRAY-MAP! */
 
+#if SCM_ENABLE_DEPRECATED == 1
+
+/* to be used as cproc in scm_ramapc to fill an array dimension with
+   "fill". */
+int
+scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED)
+{
+  unsigned long i;
+  unsigned long n = SCM_I_ARRAY_DIMS (ra)->ubnd - SCM_I_ARRAY_DIMS (ra)->lbnd + 1;
+  long inc = SCM_I_ARRAY_DIMS (ra)->inc;
+  unsigned long base = SCM_I_ARRAY_BASE (ra);
+
+  ra = SCM_I_ARRAY_V (ra);
+
+  for (i = base; n--; i += inc)
+    GVSET (ra, i, fill);
+
+  return 1;
+}
+
+/* Functions callable by ARRAY-MAP! */
 
 int
 scm_ra_eqp (SCM ra0, SCM ras)
@@ -628,37 +654,52 @@ scm_array_identity (SCM dst, SCM src)
   return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL));
 }
 
+#endif /* SCM_ENABLE_DEPRECATED */
 
-
+static int
-static int 
 ramap (SCM ra0, SCM proc, SCM ras)
 {
-  long i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
+  ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
-  long inc = SCM_I_ARRAY_DIMS (ra0)->inc;
+  size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
-  long n = SCM_I_ARRAY_DIMS (ra0)->ubnd;
+
-  long base = SCM_I_ARRAY_BASE (ra0) - i * inc;
+  scm_t_array_handle h0;
-  ra0 = SCM_I_ARRAY_V (ra0);
+  size_t i0, i0end;
+  ssize_t inc0;
+  scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0);
+  i0 = h0.base + h0.dims[0].lbnd + SCM_I_ARRAY_BASE (ra0)*h0.dims[0].inc;
+  inc0 = SCM_I_ARRAY_DIMS (ra0)->inc * h0.dims[0].inc;
+  i0end = i0 + n*inc0;
   if (scm_is_null (ras))
-    for (; i <= n; i++)
+    for (; i0 < i0end; i0 += inc0)
-      GVSET (ra0, i*inc+base, scm_call_0 (proc));
+      h0.impl->vset (&h0, i0, scm_call_0 (proc));
   else
     {
       SCM ra1 = SCM_CAR (ras);
-      SCM args;
+      scm_t_array_handle h1;
-      unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1);
+      size_t i1;
-      long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
+      ssize_t inc1;
-      ra1 = SCM_I_ARRAY_V (ra1);
+      scm_array_get_handle (SCM_I_ARRAY_V (ra1), &h1);
-      ras = scm_vector (SCM_CDR (ras));
+      i1 = h1.base + h1.dims[0].lbnd + SCM_I_ARRAY_BASE (ra1)*h1.dims[0].inc;
-      
+      inc1 = SCM_I_ARRAY_DIMS (ra1)->inc * h1.dims[0].inc;
-      for (; i <= n; i++, i1 += inc1)
+      ras = SCM_CDR (ras);
-	{
+      if (scm_is_null (ras))
-	  args = SCM_EOL;
+          for (; i0 < i0end; i0 += inc0, i1 += inc1)
-	  for (k = scm_c_vector_length (ras); k--;)
+            h0.impl->vset (&h0, i0, scm_call_1 (proc, h1.impl->vref (&h1, i1)));
-	    args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
+      else
-	  args = scm_cons (GVREF (ra1, i1), args);
+        {
-	  GVSET (ra0, i*inc+base, scm_apply_0 (proc, args));
+          ras = scm_vector (ras);
-	}
+          for (; i0 < i0end; i0 += inc0, i1 += inc1, ++i)
+            {
+              SCM args = SCM_EOL;
+              unsigned long k;
+              for (k = scm_c_vector_length (ras); k--;)
+                args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
+              h0.impl->vset (&h0, i0, scm_apply_1 (proc, h1.impl->vref (&h1, i1), args));
+            }
+        }
+      scm_array_handle_release (&h1);
     }
+  scm_array_handle_release (&h0);
   return 1;
 }
 
@@ -691,36 +732,35 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
 static int
 rafe (SCM ra0, SCM proc, SCM ras)
 {
-  long i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
+  ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd;
-  unsigned long i0 = SCM_I_ARRAY_BASE (ra0);
+  size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1;
-  long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc;
+
-  long n = SCM_I_ARRAY_DIMS (ra0)->ubnd;
+  scm_t_array_handle h0;
-  ra0 = SCM_I_ARRAY_V (ra0);
+  size_t i0, i0end;
+  ssize_t inc0;
+  scm_array_get_handle (SCM_I_ARRAY_V (ra0), &h0);
+  i0 = h0.base + h0.dims[0].lbnd + SCM_I_ARRAY_BASE (ra0)*h0.dims[0].inc;
+  inc0 = SCM_I_ARRAY_DIMS (ra0)->inc * h0.dims[0].inc;
+  i0end = i0 + n*inc0;
   if (scm_is_null (ras))
-    for (; i <= n; i++, i0 += inc0)
+    for (; i0 < i0end; i0 += inc0)
-      scm_call_1 (proc, GVREF (ra0, i0));
+      scm_call_1 (proc, h0.impl->vref (&h0, i0));
   else
     {
-      SCM ra1 = SCM_CAR (ras);
+      ras = scm_vector (ras);
-      SCM args;
+      for (; i0 < i0end; i0 += inc0, ++i)
-      unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1);
+        {
-      long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
+          SCM args = SCM_EOL;
-      ra1 = SCM_I_ARRAY_V (ra1);
+          unsigned long k;
-      ras = scm_vector (SCM_CDR (ras));
+          for (k = scm_c_vector_length (ras); k--;)
-
+            args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
-      for (; i <= n; i++, i0 += inc0, i1 += inc1)
+          scm_apply_1 (proc, h0.impl->vref (&h0, i0), args);
-	{
+        }
-	  args = SCM_EOL;
-	  for (k = scm_c_vector_length (ras); k--;)
-	    args = scm_cons (GVREF (scm_c_vector_ref (ras, k), i), args);
-	  args = scm_cons2 (GVREF (ra0, i0), GVREF (ra1, i1), args);
-	  scm_apply_0 (proc, args);
-	}
     }
+  scm_array_handle_release (&h0);
   return 1;
 }
 
-
 SCM_DEFINE (scm_array_for_each, "array-for-each", 2, 0, 1,
 	    (SCM proc, SCM ra0, SCM lra),
 	    "Apply @var{proc} to each tuple of elements of @var{ra0} @dots{}\n"

libguile/array-map.h

@@ -4,7 +4,7 @@
 #define SCM_ARRAY_MAP_H
 
 /* Copyright (C) 1995, 1996, 1997, 2000, 2006, 2008, 2009, 2010,
- *   2011 Free Software Foundation, Inc.
+ *   2011, 2013 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
@@ -31,25 +31,30 @@
 SCM_API int scm_ra_matchp (SCM ra0, SCM ras);
 SCM_API int scm_ramapc (void *cproc, SCM data, SCM ra0, SCM lra,
 			const char *what);
-SCM_API int scm_array_fill_int (SCM ra, SCM fill, SCM ignore);
 SCM_API SCM scm_array_fill_x (SCM ra, SCM fill);
 SCM_API SCM scm_array_copy_x (SCM src, SCM dst);
-SCM_API int scm_ra_eqp (SCM ra0, SCM ras);
-SCM_API int scm_ra_lessp (SCM ra0, SCM ras);
-SCM_API int scm_ra_leqp (SCM ra0, SCM ras);
-SCM_API int scm_ra_grp (SCM ra0, SCM ras);
-SCM_API int scm_ra_greqp (SCM ra0, SCM ras);
-SCM_API int scm_ra_sum (SCM ra0, SCM ras);
-SCM_API int scm_ra_difference (SCM ra0, SCM ras);
-SCM_API int scm_ra_product (SCM ra0, SCM ras);
-SCM_API int scm_ra_divide (SCM ra0, SCM ras);
-SCM_API int scm_array_identity (SCM src, SCM dst);
 SCM_API SCM scm_array_map_x (SCM ra0, SCM proc, SCM lra);
 SCM_API SCM scm_array_for_each (SCM proc, SCM ra0, SCM lra);
 SCM_API SCM scm_array_index_map_x (SCM ra, SCM proc);
 SCM_API SCM scm_array_equal_p (SCM ra0, SCM ra1);
 SCM_INTERNAL void scm_init_array_map (void);
 
+#if SCM_ENABLE_DEPRECATED == 1
+
+SCM_DEPRECATED int scm_array_fill_int (SCM ra, SCM fill, SCM ignore);
+SCM_DEPRECATED int scm_ra_eqp (SCM ra0, SCM ras);
+SCM_DEPRECATED int scm_ra_lessp (SCM ra0, SCM ras);
+SCM_DEPRECATED int scm_ra_leqp (SCM ra0, SCM ras);
+SCM_DEPRECATED int scm_ra_grp (SCM ra0, SCM ras);
+SCM_DEPRECATED int scm_ra_greqp (SCM ra0, SCM ras);
+SCM_DEPRECATED int scm_ra_sum (SCM ra0, SCM ras);
+SCM_DEPRECATED int scm_ra_difference (SCM ra0, SCM ras);
+SCM_DEPRECATED int scm_ra_product (SCM ra0, SCM ras);
+SCM_DEPRECATED int scm_ra_divide (SCM ra0, SCM ras);
+SCM_DEPRECATED int scm_array_identity (SCM src, SCM dst);
+
+#endif  /* SCM_ENABLE_DEPRECATED == 1 */
+
 #endif  /* SCM_ARRAY_MAP_H */
 
 /*

libguile/filesys.c

@@ -1111,9 +1111,10 @@ SCM_DEFINE (scm_copy_file, "copy-file", 2, 0, 0,
 SCM_DEFINE (scm_sendfile, "sendfile", 3, 1, 0,
 	    (SCM out, SCM in, SCM count, SCM offset),
 	    "Send @var{count} bytes from @var{in} to @var{out}, both of which "
-	    "are either open file ports or file descriptors.  When "
+	    "must be either open file ports or file descriptors.  When "
 	    "@var{offset} is omitted, start reading from @var{in}'s current "
-	    "position; otherwise, start reading at @var{offset}.")
+	    "position; otherwise, start reading at @var{offset}.  Return "
+	    "the number of bytes actually sent.")
 #define FUNC_NAME s_scm_sendfile
 {
 #define VALIDATE_FD_OR_PORT(cvar, svar, pos)	\
@@ -1126,9 +1127,9 @@ SCM_DEFINE (scm_sendfile, "sendfile", 3, 1, 0,
       cvar = SCM_FPORT_FDES (svar);		\
     }
 
-  size_t c_count;
+  ssize_t result SCM_UNUSED;
+  size_t c_count, total = 0;
   scm_t_off c_offset;
-  ssize_t result;
   int in_fd, out_fd;
 
   VALIDATE_FD_OR_PORT (out_fd, out, 1);
@@ -1139,9 +1140,30 @@ SCM_DEFINE (scm_sendfile, "sendfile", 3, 1, 0,
 #if defined HAVE_SYS_SENDFILE_H && defined HAVE_SENDFILE
   /* The Linux-style sendfile(2), which is different from the BSD-style.  */
 
-  result = sendfile_or_sendfile64 (out_fd, in_fd,
+  {
-				   SCM_UNBNDP (offset) ? NULL : &c_offset,
+    off_t *offset_ptr;
-				   c_count);
+
+    offset_ptr = SCM_UNBNDP (offset) ? NULL : &c_offset;
+
+    /* On Linux, when OUT_FD is a file, everything is transferred at once and
+       RESULT == C_COUNT.  However, when OUT_FD is a pipe or other "slow"
+       device, fewer bytes may be transferred, hence the loop.  RESULT == 0
+       means EOF on IN_FD, so leave the loop in that case.  */
+    do
+      {
+	result = sendfile_or_sendfile64 (out_fd, in_fd, offset_ptr,
+					 c_count - total);
+	if (result > 0)
+	  /* At this point, either OFFSET_PTR is non-NULL and it has been
+	     updated to the current offset in IN_FD, or it is NULL and IN_FD's
+	     offset has been updated.  */
+	  total += result;
+	else if (result < 0 && (errno == EINTR || errno == EAGAIN))
+	  /* Keep going.  */
+	  result = 1;
+      }
+    while (total < c_count && result > 0);
+  }
 
   /* Quoting the Linux man page: "In Linux kernels before 2.6.33, out_fd
      must refer to a socket.  Since Linux 2.6.33 it can be any file."
@@ -1152,12 +1174,13 @@ SCM_DEFINE (scm_sendfile, "sendfile", 3, 1, 0,
 #endif
   {
     char buf[8192];
-    size_t result, left;
+    size_t left;
+    int reached_eof = 0;
 
     if (!SCM_UNBNDP (offset))
       {
 	if (SCM_PORTP (in))
-	  scm_seek (in, offset, scm_from_int (SEEK_SET));
+	  scm_seek (in, scm_from_off_t (c_offset), scm_from_int (SEEK_SET));
 	else
 	  {
 	    if (lseek_or_lseek64 (in_fd, c_offset, SEEK_SET) < 0)
@@ -1165,28 +1188,32 @@ SCM_DEFINE (scm_sendfile, "sendfile", 3, 1, 0,
 	  }
       }
 
-    for (result = 0, left = c_count; result < c_count; )
+    for (total = 0, left = c_count; total < c_count && !reached_eof; )
       {
-	size_t asked, obtained;
+	size_t asked, obtained, written;
 
 	asked = SCM_MIN (sizeof buf, left);
 	obtained = full_read (in_fd, buf, asked);
 	if (obtained < asked)
-	  SCM_SYSERROR;
+          {
+            if (errno == 0)
+              reached_eof = 1;
+            else
+              SCM_SYSERROR;
+          }
 
 	left -= obtained;
 
-	obtained = full_write (out_fd, buf, asked);
+	written = full_write (out_fd, buf, obtained);
-	if (obtained < asked)
+	if (written < obtained)
 	  SCM_SYSERROR;
 
-	result += obtained;
+	total += written;
       }
 
-    return scm_from_size_t (result);
   }
 
-  return scm_from_ssize_t (result);
+  return scm_from_size_t (total);
 
 #undef VALIDATE_FD_OR_PORT
 }

libguile/fports.c

@@ -225,8 +225,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
 
   if (ndrained > 0)
     /* Put DRAINED back to PORT.  */
-    while (ndrained-- > 0)
+    scm_unget_bytes ((unsigned char *) drained, ndrained, port);
-      scm_unget_byte (drained[ndrained], port);
 
   return SCM_UNSPECIFIED;
 }
@@ -316,71 +315,35 @@ fport_canonicalize_filename (SCM filename)
     }
 }
 
+/* scm_open_file_with_encoding
+   Return a new port open on a given file.
 
-/* scm_open_file
+   The mode string must match the pattern: [rwa+]** which
- * Return a new port open on a given file.
+   is interpreted in the usual unix way.
- *
+
- * The mode string must match the pattern: [rwa+]** which
+   Unless binary mode is requested, the character encoding of the new
- * is interpreted in the usual unix way.
+   port is determined as follows: First, if GUESS_ENCODING is true,
- *
+   'file-encoding' is used to guess the encoding of the file.  If
- * Return the new port.
+   GUESS_ENCODING is false or if 'file-encoding' fails, ENCODING is used
- */
+   unless it is also false.  As a last resort, the default port encoding
-SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0,
+   is used.  It is an error to pass a non-false GUESS_ENCODING or
-	    (SCM filename, SCM mode),
+   ENCODING if binary mode is requested.
-	    "Open the file whose name is @var{filename}, and return a port\n"
+
-	    "representing that file.  The attributes of the port are\n"
+   Return the new port. */
-	    "determined by the @var{mode} string.  The way in which this is\n"
+SCM
-	    "interpreted is similar to C stdio.  The first character must be\n"
+scm_open_file_with_encoding (SCM filename, SCM mode,
-	    "one of the following:\n"
+                             SCM guess_encoding, SCM encoding)
-	    "@table @samp\n"
+#define FUNC_NAME "open-file"
-	    "@item r\n"
-	    "Open an existing file for input.\n"
-	    "@item w\n"
-	    "Open a file for output, creating it if it doesn't already exist\n"
-	    "or removing its contents if it does.\n"
-	    "@item a\n"
-	    "Open a file for output, creating it if it doesn't already\n"
-	    "exist.  All writes to the port will go to the end of the file.\n"
-	    "The \"append mode\" can be turned off while the port is in use\n"
-	    "@pxref{Ports and File Descriptors, fcntl}\n"
-	    "@end table\n"
-	    "The following additional characters can be appended:\n"
-	    "@table @samp\n"
-	    "@item b\n"
-	    "Open the underlying file in binary mode, if supported by the system.\n"
-	    "Also, open the file using the binary-compatible character encoding\n"
-	    "\"ISO-8859-1\", ignoring the port's encoding and the coding declaration\n"
-	    "at the top of the input file, if any.\n"
-	    "@item +\n"
-	    "Open the port for both input and output.  E.g., @code{r+}: open\n"
-	    "an existing file for both input and output.\n"
-	    "@item 0\n"
-	    "Create an \"unbuffered\" port.  In this case input and output\n"
-	    "operations are passed directly to the underlying port\n"
-	    "implementation without additional buffering.  This is likely to\n"
-	    "slow down I/O operations.  The buffering mode can be changed\n"
-	    "while a port is in use @pxref{Ports and File Descriptors,\n"
-	    "setvbuf}\n"
-	    "@item l\n"
-	    "Add line-buffering to the port.  The port output buffer will be\n"
-	    "automatically flushed whenever a newline character is written.\n"
-	    "@end table\n"
-	    "When the file is opened, this procedure will scan for a coding\n"
-	    "declaration@pxref{Character Encoding of Source Files}. If present\n"
-	    "will use that encoding for interpreting the file.  Otherwise, the\n"
-	    "port's encoding will be used.\n"
-	    "\n"
-	    "In theory we could create read/write ports which were buffered\n"
-	    "in one direction only.  However this isn't included in the\n"
-	    "current interfaces.  If a file cannot be opened with the access\n"
-	    "requested, @code{open-file} throws an exception.")
-#define FUNC_NAME s_scm_open_file
 {
   SCM port;
-  int fdes, flags = 0, use_encoding = 1;
+  int fdes, flags = 0, binary = 0;
   unsigned int retries;
   char *file, *md, *ptr;
 
+  if (SCM_UNLIKELY (!(scm_is_false (encoding) || scm_is_string (encoding))))
+    scm_wrong_type_arg_msg (FUNC_NAME, 0, encoding,
+                            "encoding to be string or false");
+
   scm_dynwind_begin (0);
 
   file = scm_to_locale_string (filename);
@@ -412,7 +375,7 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0,
 	  flags = (flags & ~(O_RDONLY | O_WRONLY)) | O_RDWR;
 	  break;
 	case 'b':
-	  use_encoding = 0;
+	  binary = 1;
 #if defined (O_BINARY)
 	  flags |= O_BINARY;
 #endif
@@ -451,21 +414,44 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0,
   port = scm_i_fdes_to_port (fdes, scm_i_mode_bits (mode),
                              fport_canonicalize_filename (filename));
 
-  if (use_encoding)
+  if (binary)
     {
-      /* If this file has a coding declaration, use that as the port
+      if (scm_is_true (encoding))
-	 encoding.  */
+        scm_misc_error (FUNC_NAME,
-      if (SCM_INPUT_PORT_P (port))
+                        "Encoding specified on a binary port",
-	{
+                        scm_list_1 (encoding));
-	  char *enc = scm_i_scan_for_encoding (port);
+      if (scm_is_true (guess_encoding))
-	  if (enc != NULL)
+        scm_misc_error (FUNC_NAME,
-	    scm_i_set_port_encoding_x (port, enc);
+                        "Request to guess encoding on a binary port",
-	}
+                        SCM_EOL);
+
+      /* Use the binary-friendly ISO-8859-1 encoding. */
+      scm_i_set_port_encoding_x (port, NULL);
     }
   else
-    /* If this is a binary file, use the binary-friendly ISO-8859-1
+    {
-       encoding.  */
+      char *enc = NULL;
-    scm_i_set_port_encoding_x (port, NULL);
+
+      if (scm_is_true (guess_encoding))
+        {
+          if (SCM_INPUT_PORT_P (port))
+            enc = scm_i_scan_for_encoding (port);
+          else
+            scm_misc_error (FUNC_NAME,
+                            "Request to guess encoding on an output-only port",
+                            SCM_EOL);
+        }
+
+      if (!enc && scm_is_true (encoding))
+        {
+          char *buf = scm_to_latin1_string (encoding);
+          enc = scm_gc_strdup (buf, "encoding");
+          free (buf);
+        }
+
+      if (enc)
+        scm_i_set_port_encoding_x (port, enc);
+    }
 
   scm_dynwind_end ();
 
@@ -473,6 +459,75 @@ SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM
+scm_open_file (SCM filename, SCM mode)
+{
+  return scm_open_file_with_encoding (filename, mode, SCM_BOOL_F, SCM_BOOL_F);
+}
+
+/* We can't define these using SCM_KEYWORD, because keywords have not
+   yet been initialized when scm_init_fports is called.  */
+static SCM k_guess_encoding = SCM_UNDEFINED;
+static SCM k_encoding       = SCM_UNDEFINED;
+
+SCM_DEFINE (scm_i_open_file, "open-file", 2, 0, 1,
+	    (SCM filename, SCM mode, SCM keyword_args),
+	    "Open the file whose name is @var{filename}, and return a port\n"
+	    "representing that file.  The attributes of the port are\n"
+	    "determined by the @var{mode} string.  The way in which this is\n"
+	    "interpreted is similar to C stdio.  The first character must be\n"
+	    "one of the following:\n"
+	    "@table @samp\n"
+	    "@item r\n"
+	    "Open an existing file for input.\n"
+	    "@item w\n"
+	    "Open a file for output, creating it if it doesn't already exist\n"
+	    "or removing its contents if it does.\n"
+	    "@item a\n"
+	    "Open a file for output, creating it if it doesn't already\n"
+	    "exist.  All writes to the port will go to the end of the file.\n"
+	    "The \"append mode\" can be turned off while the port is in use\n"
+	    "@pxref{Ports and File Descriptors, fcntl}\n"
+	    "@end table\n"
+	    "The following additional characters can be appended:\n"
+	    "@table @samp\n"
+	    "@item b\n"
+	    "Open the underlying file in binary mode, if supported by the system.\n"
+	    "Also, open the file using the binary-compatible character encoding\n"
+	    "\"ISO-8859-1\", ignoring the default port encoding.\n"
+	    "@item +\n"
+	    "Open the port for both input and output.  E.g., @code{r+}: open\n"
+	    "an existing file for both input and output.\n"
+	    "@item 0\n"
+	    "Create an \"unbuffered\" port.  In this case input and output\n"
+	    "operations are passed directly to the underlying port\n"
+	    "implementation without additional buffering.  This is likely to\n"
+	    "slow down I/O operations.  The buffering mode can be changed\n"
+	    "while a port is in use @pxref{Ports and File Descriptors,\n"
+	    "setvbuf}\n"
+	    "@item l\n"
+	    "Add line-buffering to the port.  The port output buffer will be\n"
+	    "automatically flushed whenever a newline character is written.\n"
+	    "@end table\n"
+	    "In theory we could create read/write ports which were buffered\n"
+	    "in one direction only.  However this isn't included in the\n"
+	    "current interfaces.  If a file cannot be opened with the access\n"
+	    "requested, @code{open-file} throws an exception.")
+#define FUNC_NAME s_scm_i_open_file
+{
+  SCM encoding = SCM_BOOL_F;
+  SCM guess_encoding = SCM_BOOL_F;
+
+  scm_c_bind_keyword_arguments (FUNC_NAME, keyword_args, 0,
+                                k_guess_encoding, &guess_encoding,
+                                k_encoding, &encoding,
+                                SCM_UNDEFINED);
+
+  return scm_open_file_with_encoding (filename, mode,
+                                      guess_encoding, encoding);
+}
+#undef FUNC_NAME
+
 
 /* Building Guile ports from a file descriptor.  */
 
@@ -921,6 +976,15 @@ scm_make_fptob ()
   return tc;
 }
 
+/* We can't initialize the keywords from 'scm_init_fports', because
+   keywords haven't yet been initialized at that point.  */
+void
+scm_init_fports_keywords ()
+{
+  k_guess_encoding = scm_from_latin1_keyword ("guess-encoding");
+  k_encoding       = scm_from_latin1_keyword ("encoding");
+}
+
 void
 scm_init_fports ()
 {

libguile/fports.h

@@ -54,6 +54,8 @@ SCM_API scm_t_bits scm_tc16_fport;
 SCM_API SCM scm_setbuf0 (SCM port);
 SCM_API SCM scm_setvbuf (SCM port, SCM mode, SCM size);
 SCM_API void scm_evict_ports (int fd);
+SCM_API SCM scm_open_file_with_encoding (SCM filename, SCM modes,
+                                         SCM guess_encoding, SCM encoding);
 SCM_API SCM scm_open_file (SCM filename, SCM modes);
 SCM_API SCM scm_fdes_to_port (int fdes, char *mode, SCM name);
 SCM_API SCM scm_file_port_p (SCM obj);
@@ -66,6 +68,7 @@ SCM_API SCM scm_set_port_revealed_x (SCM port, SCM rcount);
 SCM_API SCM scm_adjust_port_revealed_x (SCM port, SCM addend);
 
 
+SCM_INTERNAL void scm_init_fports_keywords (void);
 SCM_INTERNAL void scm_init_fports (void);
 
 /* internal functions */

libguile/gc.h

@@ -4,7 +4,7 @@
 #define SCM_GC_H
 
 /* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006,
- *   2007, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+ *   2007, 2008, 2009, 2010, 2011, 2012, 2013 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
@@ -181,6 +181,7 @@ SCM_API char *scm_gc_strdup (const char *str, const char *what)
 SCM_API char *scm_gc_strndup (const char *str, size_t n, const char *what)
   SCM_MALLOC;
 
+#define scm_gc_typed_calloc(t) ((t *) scm_gc_calloc (sizeof (t), #t))
 
 #ifdef BUILDING_LIBGUILE
 #include "libguile/bdw-gc.h"

libguile/gen-scmconfig.c

@@ -301,7 +301,7 @@ main (int argc, char *argv[])
 
   pf ("\n");
   pf ("/* same as POSIX \"struct timespec\" -- always defined */\n");
-#ifdef HAVE_STRUCT_TIMESPEC
+#ifdef HAVE_SYSTEM_STRUCT_TIMESPEC
   pf ("typedef struct timespec scm_t_timespec;\n");
 #else
   pf ("/* POSIX.4 structure for a time value.  This is like a `struct timeval'"

libguile/init.c

@@ -442,6 +442,7 @@ scm_i_init_guile (void *base)
   scm_init_gettext ();
   scm_init_ioext ();
   scm_init_keywords ();    /* Requires smob_prehistory */
+  scm_init_fports_keywords ();
   scm_init_list ();
   scm_init_random ();      /* Requires smob_prehistory */
   scm_init_macros ();      /* Requires smob_prehistory and random */

libguile/keywords.c

@@ -23,6 +23,7 @@
 #endif
 
 #include <string.h>
+#include <stdarg.h>
 
 #include "libguile/_scm.h"
 #include "libguile/async.h"
@@ -124,6 +125,72 @@ scm_from_utf8_keyword (const char *name)
   return scm_symbol_to_keyword (scm_from_utf8_symbol (name));
 }
 
+SCM_SYMBOL (scm_keyword_argument_error, "keyword-argument-error");
+
+void
+scm_c_bind_keyword_arguments (const char *subr, SCM rest,
+                              scm_t_keyword_arguments_flags flags, ...)
+{
+  va_list va;
+
+  if (SCM_UNLIKELY (!(flags & SCM_ALLOW_NON_KEYWORD_ARGUMENTS)
+                    && scm_ilength (rest) % 2 != 0))
+    scm_error (scm_keyword_argument_error,
+               subr, "Odd length of keyword argument list",
+               SCM_EOL, SCM_BOOL_F);
+
+  while (scm_is_pair (rest))
+    {
+      SCM kw_or_arg = SCM_CAR (rest);
+      SCM tail = SCM_CDR (rest);
+
+      if (scm_is_keyword (kw_or_arg) && scm_is_pair (tail))
+        {
+          SCM kw;
+          SCM *arg_p;
+
+          va_start (va, flags);
+          for (;;)
+            {
+              kw = va_arg (va, SCM);
+              if (SCM_UNBNDP (kw))
+                {
+                  /* KW_OR_ARG is not in the list of expected keywords.  */
+                  if (!(flags & SCM_ALLOW_OTHER_KEYS))
+                    scm_error (scm_keyword_argument_error,
+                               subr, "Unrecognized keyword",
+                               SCM_EOL, SCM_BOOL_F);
+                  break;
+                }
+              arg_p = va_arg (va, SCM *);
+              if (scm_is_eq (kw_or_arg, kw))
+                {
+                  /* We found the matching keyword.  Store the
+                     associated value and break out of the loop.  */
+                  *arg_p = SCM_CAR (tail);
+                  break;
+                }
+            }
+          va_end (va);
+
+          /* Advance REST.  */
+          rest = SCM_CDR (tail);
+        }
+      else
+        {
+          /* The next argument is not a keyword, or is a singleton
+             keyword at the end of REST.  */
+          if (!(flags & SCM_ALLOW_NON_KEYWORD_ARGUMENTS))
+            scm_error (scm_keyword_argument_error,
+                       subr, "Invalid keyword",
+                       SCM_EOL, SCM_BOOL_F);
+
+           /* Advance REST.  */
+           rest = tail;
+        }
+    }
+}
+
 /* njrev: critical sections reviewed so far up to here */
 void
 scm_init_keywords ()

libguile/keywords.h

@@ -41,6 +41,18 @@ SCM_API SCM scm_from_locale_keywordn (const char *name, size_t len);
 SCM_API SCM scm_from_latin1_keyword (const char *name);
 SCM_API SCM scm_from_utf8_keyword (const char *name);
 
+enum scm_keyword_arguments_flags
+{
+  SCM_ALLOW_OTHER_KEYS            = (1U << 0),
+  SCM_ALLOW_NON_KEYWORD_ARGUMENTS = (1U << 1)
+};
+
+typedef enum scm_keyword_arguments_flags scm_t_keyword_arguments_flags;
+
+SCM_API void
+scm_c_bind_keyword_arguments (const char *subr, SCM rest,
+                              scm_t_keyword_arguments_flags flags, ...);
+
 SCM_INTERNAL void scm_init_keywords (void);
 
 #endif  /* SCM_KEYWORDS_H */

libguile/ports-internal.h

@@ -0,0 +1,66 @@
+/*
+ * ports-internal.h - internal-only declarations for ports.
+ *
+ * Copyright (C) 2013 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
+ */
+
+#ifndef SCM_PORTS_INTERNAL
+#define SCM_PORTS_INTERNAL
+
+#include "libguile/_scm.h"
+#include "libguile/ports.h"
+
+enum scm_port_encoding_mode {
+  SCM_PORT_ENCODING_MODE_UTF8,
+  SCM_PORT_ENCODING_MODE_LATIN1,
+  SCM_PORT_ENCODING_MODE_ICONV
+};
+
+typedef enum scm_port_encoding_mode scm_t_port_encoding_mode;
+
+/* This is a separate object so that only those ports that use iconv
+   cause finalizers to be registered.  */
+struct scm_iconv_descriptors
+{
+  /* input/output iconv conversion descriptors */
+  void *input_cd;
+  void *output_cd;
+};
+
+typedef struct scm_iconv_descriptors scm_t_iconv_descriptors;
+
+struct scm_port_internal
+{
+  unsigned at_stream_start_for_bom_read  : 1;
+  unsigned at_stream_start_for_bom_write : 1;
+  scm_t_port_encoding_mode encoding_mode;
+  scm_t_iconv_descriptors *iconv_descriptors;
+  int pending_eof;
+  SCM alist;
+};
+
+typedef struct scm_port_internal scm_t_port_internal;
+
+#define SCM_UNICODE_BOM  0xFEFFUL  /* Unicode byte-order mark */
+
+#define SCM_PORT_GET_INTERNAL(x)  (SCM_PTAB_ENTRY(x)->internal)
+
+SCM_INTERNAL scm_t_iconv_descriptors *
+scm_i_port_iconv_descriptors (SCM port, scm_t_port_rw_active mode);
+
+#endif

libguile/ports.c

@@ -55,6 +55,7 @@
 #include "libguile/mallocs.h"
 #include "libguile/validate.h"
 #include "libguile/ports.h"
+#include "libguile/ports-internal.h"
 #include "libguile/vectors.h"
 #include "libguile/weak-set.h"
 #include "libguile/fluids.h"
@@ -329,6 +330,30 @@ scm_set_port_input_waiting (scm_t_bits tc, int (*input_waiting) (SCM))
   scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->input_waiting = input_waiting;
 }
 
+static void
+scm_i_set_pending_eof (SCM port)
+{
+  SCM_PORT_GET_INTERNAL (port)->pending_eof = 1;
+}
+
+static void
+scm_i_clear_pending_eof (SCM port)
+{
+  SCM_PORT_GET_INTERNAL (port)->pending_eof = 0;
+}
+
+SCM
+scm_i_port_alist (SCM port)
+{
+  return SCM_PORT_GET_INTERNAL (port)->alist;
+}
+
+void
+scm_i_set_port_alist_x (SCM port, SCM alist)
+{
+  SCM_PORT_GET_INTERNAL (port)->alist = alist;
+}
+
 
 
 /* Standard ports --- current input, output, error, and more(!).  */
@@ -641,9 +666,11 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits,
 {
   SCM ret;
   scm_t_port *entry;
+  scm_t_port_internal *pti;
   scm_t_ptob_descriptor *ptob;
 
-  entry = (scm_t_port *) scm_gc_calloc (sizeof (scm_t_port), "port");
+  entry = scm_gc_typed_calloc (scm_t_port);
+  pti = scm_gc_typed_calloc (scm_t_port_internal);
   ptob = scm_c_port_type_ref (SCM_TC2PTOBNUM (tag));
 
   ret = scm_words (tag | mode_bits, 3);
@@ -653,6 +680,7 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits,
   entry->lock = scm_gc_malloc_pointerless (sizeof (*entry->lock), "port lock");
   scm_i_pthread_mutex_init (entry->lock, scm_i_pthread_mutexattr_recursive);
 
+  entry->internal = pti;
   entry->file_name = SCM_BOOL_F;
   entry->rw_active = SCM_PORT_NEITHER;
   entry->port = ret;
@@ -660,24 +688,28 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits,
 
   if (encoding_matches (encoding, "UTF-8"))
     {
-      entry->encoding_mode = SCM_PORT_ENCODING_MODE_UTF8;
+      pti->encoding_mode = SCM_PORT_ENCODING_MODE_UTF8;
       entry->encoding = "UTF-8";
     }
   else if (encoding_matches (encoding, "ISO-8859-1"))
     {
-      entry->encoding_mode = SCM_PORT_ENCODING_MODE_LATIN1;
+      pti->encoding_mode = SCM_PORT_ENCODING_MODE_LATIN1;
       entry->encoding = "ISO-8859-1";
     }
   else
     {
-      entry->encoding_mode = SCM_PORT_ENCODING_MODE_ICONV;
+      pti->encoding_mode = SCM_PORT_ENCODING_MODE_ICONV;
       entry->encoding = canonicalize_encoding (encoding);
     }
 
   entry->ilseq_handler = handler;
-  entry->iconv_descriptors = NULL;
+  pti->iconv_descriptors = NULL;
 
-  entry->alist = SCM_EOL;
+  pti->at_stream_start_for_bom_read  = 1;
+  pti->at_stream_start_for_bom_write = 1;
+
+  pti->pending_eof = 0;
+  pti->alist = SCM_EOL;
 
   if (SCM_PORT_DESCRIPTOR (ret)->free)
     scm_i_set_finalizer (SCM2PTR (ret), finalize_port, NULL);
@@ -783,7 +815,7 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0,
 	    "descriptors.")
 #define FUNC_NAME s_scm_close_port
 {
-  scm_t_port *p;
+  scm_t_port_internal *pti;
   int rv;
 
   port = SCM_COERCE_OUTPORT (port);
@@ -792,7 +824,7 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0,
   if (SCM_CLOSEDP (port))
     return SCM_BOOL_F;
 
-  p = SCM_PTAB_ENTRY (port);
+  pti = SCM_PORT_GET_INTERNAL (port);
   SCM_CLR_PORT_OPEN_FLAG (port);
 
   if (SCM_PORT_DESCRIPTOR (port)->flags & SCM_PORT_TYPE_HAS_FLUSH)
@@ -805,12 +837,12 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0,
   else
     rv = 0;
 
-  if (p->iconv_descriptors)
+  if (pti->iconv_descriptors)
     {
       /* If we don't get here, the iconv_descriptors finalizer will
          clean up. */
-      close_iconv_descriptors (p->iconv_descriptors);
+      close_iconv_descriptors (pti->iconv_descriptors);
-      p->iconv_descriptors = NULL;
+      pti->iconv_descriptors = NULL;
     }
 
   return scm_from_bool (rv >= 0);
@@ -974,6 +1006,66 @@ scm_i_set_default_port_conversion_handler (scm_t_string_failed_conversion_handle
 		   strategy);
 }
 
+static void
+scm_i_unget_bytes_unlocked (const unsigned char *buf, size_t len, SCM port);
+
+/* If the next LEN bytes from PORT are equal to those in BYTES, then
+   return 1, else return 0.  Leave the port position unchanged.  */
+static int
+looking_at_bytes (SCM port, const unsigned char *bytes, int len)
+{
+  scm_t_port *pt = SCM_PTAB_ENTRY (port);
+  int i = 0;
+
+  while (i < len && scm_peek_byte_or_eof_unlocked (port) == bytes[i])
+    {
+      pt->read_pos++;
+      i++;
+    }
+  scm_i_unget_bytes_unlocked (bytes, i, port);
+  return (i == len);
+}
+
+static const unsigned char scm_utf8_bom[3]    = {0xEF, 0xBB, 0xBF};
+static const unsigned char scm_utf16be_bom[2] = {0xFE, 0xFF};
+static const unsigned char scm_utf16le_bom[2] = {0xFF, 0xFE};
+static const unsigned char scm_utf32be_bom[4] = {0x00, 0x00, 0xFE, 0xFF};
+static const unsigned char scm_utf32le_bom[4] = {0xFF, 0xFE, 0x00, 0x00};
+
+/* Decide what byte order to use for a UTF-16 port.  Return "UTF-16BE"
+   or "UTF-16LE".  MODE must be either SCM_PORT_READ or SCM_PORT_WRITE,
+   and specifies which operation is about to be done.  The MODE
+   determines how we will decide the byte order.  We deliberately avoid
+   reading from the port unless the user is about to do so.  If the user
+   is about to read, then we look for a BOM, and if present, we use it
+   to determine the byte order.  Otherwise we choose big endian, as
+   recommended by the Unicode Standard.  Note that the BOM (if any) is
+   not consumed here.  */
+static const char *
+decide_utf16_encoding (SCM port, scm_t_port_rw_active mode)
+{
+  if (mode == SCM_PORT_READ
+      && SCM_PORT_GET_INTERNAL (port)->at_stream_start_for_bom_read
+      && looking_at_bytes (port, scm_utf16le_bom, sizeof scm_utf16le_bom))
+    return "UTF-16LE";
+  else
+    return "UTF-16BE";
+}
+
+/* Decide what byte order to use for a UTF-32 port.  Return "UTF-32BE"
+   or "UTF-32LE".  See the comment above 'decide_utf16_encoding' for
+   details.  */
+static const char *
+decide_utf32_encoding (SCM port, scm_t_port_rw_active mode)
+{
+  if (mode == SCM_PORT_READ
+      && SCM_PORT_GET_INTERNAL (port)->at_stream_start_for_bom_read
+      && looking_at_bytes (port, scm_utf32le_bom, sizeof scm_utf32le_bom))
+    return "UTF-32LE";
+  else
+    return "UTF-32BE";
+}
+
 static void
 finalize_iconv_descriptors (void *ptr, void *data)
 {
@@ -1057,25 +1149,36 @@ close_iconv_descriptors (scm_t_iconv_descriptors *id)
 }
 
 scm_t_iconv_descriptors *
-scm_i_port_iconv_descriptors (SCM port)
+scm_i_port_iconv_descriptors (SCM port, scm_t_port_rw_active mode)
 {
-  scm_t_port *pt;
+  scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port);
 
-  pt = SCM_PTAB_ENTRY (port);
+  assert (pti->encoding_mode == SCM_PORT_ENCODING_MODE_ICONV);
 
-  assert (pt->encoding_mode == SCM_PORT_ENCODING_MODE_ICONV);
+  if (!pti->iconv_descriptors)
-
-  if (!pt->iconv_descriptors)
     {
+      scm_t_port *pt = SCM_PTAB_ENTRY (port);
+      const char *precise_encoding;
+
       if (!pt->encoding)
         pt->encoding = "ISO-8859-1";
-      pt->iconv_descriptors =
+
-        open_iconv_descriptors (pt->encoding,
+      /* If the specified encoding is UTF-16 or UTF-32, then make
+         that more precise by deciding what byte order to use. */
+      if (strcmp (pt->encoding, "UTF-16") == 0)
+        precise_encoding = decide_utf16_encoding (port, mode);
+      else if (strcmp (pt->encoding, "UTF-32") == 0)
+        precise_encoding = decide_utf32_encoding (port, mode);
+      else
+        precise_encoding = pt->encoding;
+
+      pti->iconv_descriptors =
+        open_iconv_descriptors (precise_encoding,
                                 SCM_INPUT_PORT_P (port),
                                 SCM_OUTPUT_PORT_P (port));
     }
 
-  return pt->iconv_descriptors;
+  return pti->iconv_descriptors;
 }
 
 /* The name of the encoding is itself encoded in ASCII.  */
@@ -1083,36 +1186,39 @@ void
 scm_i_set_port_encoding_x (SCM port, const char *encoding)
 {
   scm_t_port *pt;
+  scm_t_port_internal *pti;
   scm_t_iconv_descriptors *prev;
 
   /* Set the character encoding for this port.  */
   pt = SCM_PTAB_ENTRY (port);
-  prev = pt->iconv_descriptors;
+  pti = SCM_PORT_GET_INTERNAL (port);
+  prev = pti->iconv_descriptors;
+
+  /* In order to handle cases where the encoding changes mid-stream
+     (e.g. within an HTTP stream, or within a file that is composed of
+     segments with different encodings), we consider this to be "stream
+     start" for purposes of BOM handling, regardless of our actual file
+     position. */
+  pti->at_stream_start_for_bom_read  = 1;
+  pti->at_stream_start_for_bom_write = 1;
 
   if (encoding_matches (encoding, "UTF-8"))
     {
       pt->encoding = "UTF-8";
-      pt->encoding_mode = SCM_PORT_ENCODING_MODE_UTF8;
+      pti->encoding_mode = SCM_PORT_ENCODING_MODE_UTF8;
-      pt->iconv_descriptors = NULL;
     }
   else if (encoding_matches (encoding, "ISO-8859-1"))
     {
       pt->encoding = "ISO-8859-1";
-      pt->encoding_mode = SCM_PORT_ENCODING_MODE_LATIN1;
+      pti->encoding_mode = SCM_PORT_ENCODING_MODE_LATIN1;
-      pt->iconv_descriptors = NULL;
     }
   else
     {
-      /* Open descriptors before mutating the port. */
+      pt->encoding = canonicalize_encoding (encoding);
-      char *gc_encoding = canonicalize_encoding (encoding);
+      pti->encoding_mode = SCM_PORT_ENCODING_MODE_ICONV;
-      pt->iconv_descriptors =
-        open_iconv_descriptors (gc_encoding,
-                                SCM_INPUT_PORT_P (port),
-                                SCM_OUTPUT_PORT_P (port));
-      pt->encoding = gc_encoding;
-      pt->encoding_mode = SCM_PORT_ENCODING_MODE_ICONV;
     }
 
+  pti->iconv_descriptors = NULL;
   if (prev)
     close_iconv_descriptors (prev);
 }
@@ -1338,17 +1444,21 @@ swap_buffer (void *data)
   psb->size = old_size;
 }
 
+static int scm_i_fill_input_unlocked (SCM port);
+
 size_t
 scm_c_read_unlocked (SCM port, void *buffer, size_t size)
 #define FUNC_NAME "scm_c_read"
 {
   scm_t_port *pt;
+  scm_t_port_internal *pti;
   size_t n_read = 0, n_available;
   struct port_and_swap_buffer psb;
 
   SCM_VALIDATE_OPINPORT (1, port);
 
   pt = SCM_PTAB_ENTRY (port);
+  pti = SCM_PORT_GET_INTERNAL (port);
   if (pt->rw_active == SCM_PORT_WRITE)
     SCM_PORT_DESCRIPTOR (port)->flush (port);
 
@@ -1370,24 +1480,23 @@ scm_c_read_unlocked (SCM port, void *buffer, size_t size)
   if (size == 0)
     return n_read;
 
-  /* Now we will call scm_fill_input repeatedly until we have read the
+  /* Now we will call scm_i_fill_input_unlocked repeatedly until we have
-     requested number of bytes.  (Note that a single scm_fill_input
+     read the requested number of bytes.  (Note that a single
-     call does not guarantee to fill the whole of the port's read
+     scm_i_fill_input_unlocked call does not guarantee to fill the whole
-     buffer.) */
+     of the port's read buffer.) */
   if (pt->read_buf_size <= 1
-      && pt->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
+      && pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
     {
-      /* The port that we are reading from is unbuffered - i.e. does
+      /* The port that we are reading from is unbuffered - i.e. does not
-	 not have its own persistent buffer - but we have a buffer,
+	 have its own persistent buffer - but we have a buffer, provided
-	 provided by our caller, that is the right size for the data
+	 by our caller, that is the right size for the data that is
-	 that is wanted.  For the following scm_fill_input calls,
+	 wanted.  For the following scm_i_fill_input_unlocked calls,
-	 therefore, we use the buffer in hand as the port's read
+	 therefore, we use the buffer in hand as the port's read buffer.
-	 buffer.
 
-	 We need to make sure that the port's normal (1 byte) buffer
+	 We need to make sure that the port's normal (1 byte) buffer is
-	 is reinstated in case one of the scm_fill_input () calls
+	 reinstated in case one of the scm_i_fill_input_unlocked ()
-	 throws an exception; we use the scm_dynwind_* API to achieve
+	 calls throws an exception; we use the scm_dynwind_* API to
-	 that. 
+	 achieve that.
 
          A consequence of this optimization is that the fill_input
          functions can't unget characters.  That'll push data to the
@@ -1402,9 +1511,9 @@ scm_c_read_unlocked (SCM port, void *buffer, size_t size)
       scm_dynwind_rewind_handler (swap_buffer, &psb, SCM_F_WIND_EXPLICITLY);
       scm_dynwind_unwind_handler (swap_buffer, &psb, SCM_F_WIND_EXPLICITLY);
 
-      /* Call scm_fill_input until we have all the bytes that we need,
+      /* Call scm_i_fill_input_unlocked until we have all the bytes that
-	 or we hit EOF. */
+	 we need, or we hit EOF. */
-      while (pt->read_buf_size && (scm_fill_input_unlocked (port) != EOF))
+      while (pt->read_buf_size && (scm_i_fill_input_unlocked (port) != EOF))
 	{
 	  pt->read_buf_size -= (pt->read_end - pt->read_pos);
 	  pt->read_pos = pt->read_buf = pt->read_end;
@@ -1428,7 +1537,7 @@ scm_c_read_unlocked (SCM port, void *buffer, size_t size)
 	 that a custom port implementation's entry points (in
 	 particular, fill_input) can rely on the buffer always being
 	 the same as they first set up. */
-      while (size && (scm_fill_input_unlocked (port) != EOF))
+      while (size && (scm_i_fill_input_unlocked (port) != EOF))
 	{
 	  n_available = min (size, pt->read_end - pt->read_pos);
 	  memcpy (buffer, pt->read_pos, n_available);
@@ -1686,64 +1795,77 @@ get_iconv_codepoint (SCM port, scm_t_wchar *codepoint,
 		     char buf[SCM_MBCHAR_BUF_SIZE], size_t *len)
 {
   scm_t_iconv_descriptors *id;
-  int err, byte_read;
-  size_t bytes_consumed, output_size;
-  char *output;
   scm_t_uint8 utf8_buf[SCM_MBCHAR_BUF_SIZE];
+  size_t input_size = 0;
 
-  id = scm_i_port_iconv_descriptors (port);
+  id = scm_i_port_iconv_descriptors (port, SCM_PORT_READ);
 
-  for (output_size = 0, output = (char *) utf8_buf,
+  for (;;)
-	 bytes_consumed = 0, err = 0;
-       err == 0 && output_size == 0
-	 && (bytes_consumed == 0 || byte_read != EOF);
-       bytes_consumed++)
     {
-      char *input;
+      int byte_read;
+      char *input, *output;
       size_t input_left, output_left, done;
 
       byte_read = scm_get_byte_or_eof_unlocked (port);
-      if (byte_read == EOF)
+      if (SCM_UNLIKELY (byte_read == EOF))
 	{
-	  if (bytes_consumed == 0)
+          if (SCM_LIKELY (input_size == 0))
-	    {
+            {
-	      *codepoint = (scm_t_wchar) EOF;
+              *codepoint = (scm_t_wchar) EOF;
-	      *len = 0;
+              *len = input_size;
-	      return 0;
+              return 0;
-	    }
+            }
-	  else
+          else
-	    continue;
+            {
+              /* EOF found in the middle of a multibyte character. */
+              scm_i_set_pending_eof (port);
+              return EILSEQ;
+            }
 	}
 
-      buf[bytes_consumed] = byte_read;
+      buf[input_size++] = byte_read;
 
       input = buf;
-      input_left = bytes_consumed + 1;
+      input_left = input_size;
+      output = (char *) utf8_buf;
       output_left = sizeof (utf8_buf);
 
       done = iconv (id->input_cd, &input, &input_left, &output, &output_left);
+
       if (done == (size_t) -1)
 	{
-	  err = errno;
+	  int err = errno;
-	  if (err == EINVAL)
+	  if (SCM_LIKELY (err == EINVAL))
-	    /* Missing input: keep trying.  */
+            /* The input byte sequence did not form a complete
-	    err = 0;
+               character.  Read another byte and try again. */
+            continue;
+          else
+            return err;
 	}
       else
-	output_size = sizeof (utf8_buf) - output_left;
+        {
+          size_t output_size = sizeof (utf8_buf) - output_left;
+          if (SCM_LIKELY (output_size > 0))
+            {
+              /* iconv generated output.  Convert the UTF8_BUF sequence
+                 to a Unicode code point.  */
+              *codepoint = utf8_to_codepoint (utf8_buf, output_size);
+              *len = input_size;
+              return 0;
+            }
+          else
+            {
+              /* iconv consumed some bytes without producing any output.
+                 Most likely this means that a Unicode byte-order mark
+                 (BOM) was consumed, which should not be included in the
+                 returned buf.  Shift any remaining bytes to the beginning
+                 of buf, and continue the loop. */
+              memmove (buf, input, input_left);
+              input_size = input_left;
+              continue;
+            }
+        }
     }
-
-  if (SCM_UNLIKELY (output_size == 0))
-    /* An unterminated sequence.  */
-    err = EILSEQ;
-  else if (SCM_LIKELY (err == 0))
-    {
-      /* Convert the UTF8_BUF sequence to a Unicode code point.  */
-      *codepoint = utf8_to_codepoint (utf8_buf, output_size);
-      *len = bytes_consumed;
-    }
-
-  return err;
 }
 
 /* Read a codepoint from PORT and return it in *CODEPOINT.  Fill BUF
@@ -1756,16 +1878,35 @@ get_codepoint (SCM port, scm_t_wchar *codepoint,
 {
   int err;
   scm_t_port *pt = SCM_PTAB_ENTRY (port);
+  scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port);
 
-  if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8)
+  if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8)
     err = get_utf8_codepoint (port, codepoint, (scm_t_uint8 *) buf, len);
-  else if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
+  else if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
     err = get_latin1_codepoint (port, codepoint, buf, len);
   else
     err = get_iconv_codepoint (port, codepoint, buf, len);
 
   if (SCM_LIKELY (err == 0))
-    update_port_lf (*codepoint, port);
+    {
+      if (SCM_UNLIKELY (pti->at_stream_start_for_bom_read))
+        {
+          /* Record that we're no longer at stream start. */
+          pti->at_stream_start_for_bom_read = 0;
+          if (pt->rw_random)
+            pti->at_stream_start_for_bom_write = 0;
+
+          /* If we just read a BOM in an encoding that recognizes them,
+             then silently consume it and read another code point. */
+          if (SCM_UNLIKELY
+              (*codepoint == SCM_UNICODE_BOM
+               && (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8
+                   || strcmp (pt->encoding, "UTF-16") == 0
+                   || strcmp (pt->encoding, "UTF-32") == 0)))
+            return get_codepoint (port, codepoint, buf, len);
+        }
+      update_port_lf (*codepoint, port);
+    }
   else if (pt->ilseq_handler == SCM_ICONVEH_QUESTION_MARK)
     {
       *codepoint = '?';
@@ -1837,52 +1978,28 @@ SCM_DEFINE (scm_read_char, "read-char", 0, 1, 0,
 
 
 /* Pushback.  */
+
 
-void 
+
-scm_unget_byte_unlocked (int c, SCM port)
+static void
-#define FUNC_NAME "scm_unget_byte"
+scm_i_unget_bytes_unlocked (const unsigned char *buf, size_t len, SCM port)
+#define FUNC_NAME "scm_unget_bytes"
 {
   scm_t_port *pt = SCM_PTAB_ENTRY (port);
+  size_t old_len, new_len;
 
-  if (pt->read_buf == pt->putback_buf)
+  scm_i_clear_pending_eof (port);
-    /* already using the put-back buffer.  */
-    {
-      /* enlarge putback_buf if necessary.  */
-      if (pt->read_end == pt->read_buf + pt->read_buf_size
-	  && pt->read_buf == pt->read_pos)
-	{
-	  size_t new_size = pt->read_buf_size * 2;
-	  unsigned char *tmp = (unsigned char *)
-	    scm_gc_realloc (pt->putback_buf, pt->read_buf_size, new_size,
-			    "putback buffer");
 
-	  pt->read_pos = pt->read_buf = pt->putback_buf = tmp;
+  if (pt->read_buf != pt->putback_buf)
-	  pt->read_end = pt->read_buf + pt->read_buf_size;
-	  pt->read_buf_size = pt->putback_buf_size = new_size;
-	}
-
-      /* shift any existing bytes to buffer + 1.  */
-      if (pt->read_pos == pt->read_end)
-	pt->read_end = pt->read_buf + 1;
-      else if (pt->read_pos != pt->read_buf + 1)
-	{
-	  int count = pt->read_end - pt->read_pos;
-
-	  memmove (pt->read_buf + 1, pt->read_pos, count);
-	  pt->read_end = pt->read_buf + 1 + count;
-	}
-
-      pt->read_pos = pt->read_buf;
-    }
-  else
     /* switch to the put-back buffer.  */
     {
       if (pt->putback_buf == NULL)
 	{
+          pt->putback_buf_size = (len > SCM_INITIAL_PUTBACK_BUF_SIZE
+                                  ? len : SCM_INITIAL_PUTBACK_BUF_SIZE);
 	  pt->putback_buf
 	    = (unsigned char *) scm_gc_malloc_pointerless
-	    (SCM_INITIAL_PUTBACK_BUF_SIZE, "putback buffer");
+	    (pt->putback_buf_size, "putback buffer");
-	  pt->putback_buf_size = SCM_INITIAL_PUTBACK_BUF_SIZE;
 	}
 
       pt->saved_read_buf = pt->read_buf;
@@ -1890,27 +2007,97 @@ scm_unget_byte_unlocked (int c, SCM port)
       pt->saved_read_end = pt->read_end;
       pt->saved_read_buf_size = pt->read_buf_size;
 
-      pt->read_pos = pt->read_buf = pt->putback_buf;
+      /* Put read_pos at the end of the buffer, so that ungets will not
-      pt->read_end = pt->read_buf + 1;
+         have to shift the buffer contents each time.  */
+      pt->read_buf = pt->putback_buf;
+      pt->read_pos = pt->read_end = pt->putback_buf + pt->putback_buf_size;
       pt->read_buf_size = pt->putback_buf_size;
     }
 
-  *pt->read_buf = c;
+  old_len = pt->read_end - pt->read_pos;
+  new_len = old_len + len;
+
+  if (new_len > pt->read_buf_size)
+    /* The putback buffer needs to be enlarged.  */
+    {
+      size_t new_buf_size;
+      unsigned char *new_buf, *new_end, *new_pos;
+
+      new_buf_size = pt->read_buf_size * 2;
+      if (new_buf_size < new_len)
+        new_buf_size = new_len;
+
+      new_buf = (unsigned char *)
+        scm_gc_malloc_pointerless (new_buf_size, "putback buffer");
+
+      /* Put the bytes at the end of the buffer, so that future
+         ungets won't need to shift the buffer.  */
+      new_end = new_buf + new_buf_size;
+      new_pos = new_end - old_len;
+      memcpy (new_pos, pt->read_pos, old_len);
+
+      pt->read_buf = pt->putback_buf = new_buf;
+      pt->read_pos = new_pos;
+      pt->read_end = new_end;
+      pt->read_buf_size = pt->putback_buf_size = new_buf_size;
+    }
+  else if (pt->read_buf + len < pt->read_pos)
+    /* If needed, shift the existing buffer contents up.
+       This should not happen unless some external code
+       manipulates the putback buffer pointers.  */
+    {
+      unsigned char *new_end = pt->read_buf + pt->read_buf_size;
+      unsigned char *new_pos = new_end - old_len;
+
+      memmove (new_pos, pt->read_pos, old_len);
+      pt->read_pos = new_pos;
+      pt->read_end = new_end;
+    }
+
+  /* Move read_pos back and copy the bytes there.  */
+  pt->read_pos -= len;
+  memcpy (pt->read_buf + (pt->read_pos - pt->read_buf), buf, len);
+
+  if (pt->rw_active == SCM_PORT_WRITE)
+    scm_flush (port);
 
   if (pt->rw_random)
     pt->rw_active = SCM_PORT_READ;
 }
 #undef FUNC_NAME
 
-void 
+void
-scm_unget_byte (int c, SCM port)
+scm_unget_bytes_unlocked (const unsigned char *buf, size_t len, SCM port)
+{
+  scm_i_unget_bytes_unlocked (buf, len, port);
+}
+
+void
+scm_unget_byte_unlocked (int c, SCM port)
+{
+  unsigned char byte = c;
+  scm_i_unget_bytes_unlocked (&byte, 1, port);
+}
+
+void
+scm_unget_bytes (const unsigned char *buf, size_t len, SCM port)
 {
   scm_i_pthread_mutex_t *lock;
   scm_c_lock_port (port, &lock);
-  scm_unget_byte_unlocked (c, port);
+  scm_i_unget_bytes_unlocked (buf, len, port);
+  if (lock)
+    scm_i_pthread_mutex_unlock (lock);
+}
+
+void 
+scm_unget_byte (int c, SCM port)
+{
+  unsigned char byte = c;
+  scm_i_pthread_mutex_t *lock;
+  scm_c_lock_port (port, &lock);
+  scm_i_unget_bytes_unlocked (&byte, 1, port);
   if (lock)
     scm_i_pthread_mutex_unlock (lock);
-  
 }
 
 void
@@ -1921,7 +2108,6 @@ scm_ungetc_unlocked (scm_t_wchar c, SCM port)
   char *result;
   char result_buf[10];
   size_t len;
-  int i;
 
   len = sizeof (result_buf);
   result = u32_conv_to_encoding (pt->encoding,
@@ -1934,8 +2120,7 @@ scm_ungetc_unlocked (scm_t_wchar c, SCM port)
 			"conversion to port encoding failed",
 			SCM_BOOL_F, SCM_MAKE_CHAR (c));
 
-  for (i = len - 1; i >= 0; i--)
+  scm_i_unget_bytes_unlocked ((unsigned char *) result, len, port);
-    scm_unget_byte_unlocked (result[i], port);
 
   if (SCM_UNLIKELY (result != result_buf))
     free (result);
@@ -2014,7 +2199,7 @@ SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0,
   SCM result;
   scm_t_wchar c;
   char bytes[SCM_MBCHAR_BUF_SIZE];
-  long column, line, i;
+  long column, line;
   size_t len;
 
   if (SCM_UNBNDP (port))
@@ -2026,8 +2211,7 @@ SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0,
 
   err = get_codepoint (port, &c, bytes, &len);
 
-  for (i = len - 1; i >= 0; i--)
+  scm_i_unget_bytes_unlocked ((unsigned char *) bytes, len, port);
-    scm_unget_byte_unlocked (bytes[i], port);
 
   SCM_COL (port) = column;
   SCM_LINUM (port) = line;
@@ -2040,7 +2224,10 @@ SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0,
       result = SCM_BOOL_F;
     }
   else if (c == EOF)
-    result = SCM_EOF_VAL;
+    {
+      scm_i_set_pending_eof (port);
+      result = SCM_EOF_VAL;
+    }
   else
     result = SCM_MAKE_CHAR (c);
 
@@ -2113,13 +2300,20 @@ scm_port_non_buffer (scm_t_port *pt)
 /* this should only be called when the read buffer is empty.  it
    tries to refill the read buffer.  it returns the first char from
    the port, which is either EOF or *(pt->read_pos).  */
-int
+static int
-scm_fill_input_unlocked (SCM port)
+scm_i_fill_input_unlocked (SCM port)
 {
   scm_t_port *pt = SCM_PTAB_ENTRY (port);
+  scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port);
 
   assert (pt->read_pos == pt->read_end);
 
+  if (pti->pending_eof)
+    {
+      pti->pending_eof = 0;
+      return EOF;
+    }
+
   if (pt->read_buf == pt->putback_buf)
     {
       /* finished reading put-back chars.  */
@@ -2148,6 +2342,51 @@ scm_fill_input (SCM port)
   return ret;
 }
 
+/* Slow-path fallback for 'scm_get_byte_or_eof_unlocked' */
+int
+scm_slow_get_byte_or_eof_unlocked (SCM port)
+{
+  scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+  if (pt->rw_active == SCM_PORT_WRITE)
+    scm_flush_unlocked (port);
+
+  if (pt->rw_random)
+    pt->rw_active = SCM_PORT_READ;
+
+  if (pt->read_pos >= pt->read_end)
+    {
+      if (SCM_UNLIKELY (scm_i_fill_input_unlocked (port) == EOF))
+	return EOF;
+    }
+
+  return *pt->read_pos++;
+}
+
+/* Slow-path fallback for 'scm_peek_byte_or_eof_unlocked' */
+int
+scm_slow_peek_byte_or_eof_unlocked (SCM port)
+{
+  scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+  if (pt->rw_active == SCM_PORT_WRITE)
+    scm_flush_unlocked (port);
+
+  if (pt->rw_random)
+    pt->rw_active = SCM_PORT_READ;
+
+  if (pt->read_pos >= pt->read_end)
+    {
+      if (SCM_UNLIKELY (scm_i_fill_input_unlocked (port) == EOF))
+        {
+          scm_i_set_pending_eof (port);
+          return EOF;
+        }
+    }
+
+  return *pt->read_pos;
+}
+
 /* Move up to READ_LEN bytes from PORT's putback and/or read buffers
    into memory starting at DEST.  Return the number of bytes moved.
    PORT's line/column numbers are left unchanged.  */
@@ -2230,6 +2469,7 @@ scm_end_input_unlocked (SCM port)
   long offset;
   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 
+  scm_i_clear_pending_eof (port);
   if (pt->read_buf == pt->putback_buf)
     {
       offset = pt->read_end - pt->read_pos;
@@ -2294,6 +2534,12 @@ scm_flush (SCM port)
   
 }
 
+int
+scm_fill_input_unlocked (SCM port)
+{
+  return scm_i_fill_input_unlocked (port);
+}
+
 
 
 
@@ -2503,6 +2749,7 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0,
 
   if (SCM_OPPORTP (fd_port))
     {
+      scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (fd_port);
       scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (fd_port);
       off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset);
       off_t_or_off64_t rv;
@@ -2511,7 +2758,14 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0,
 	SCM_MISC_ERROR ("port is not seekable", 
                         scm_cons (fd_port, SCM_EOL));
       else
-	rv = ptob->seek (fd_port, off, how);
+        rv = ptob->seek (fd_port, off, how);
+
+      /* Set stream-start flags according to new position. */
+      pti->at_stream_start_for_bom_read  = (rv == 0);
+      pti->at_stream_start_for_bom_write = (rv == 0);
+
+      scm_i_clear_pending_eof (fd_port);
+
       return scm_from_off_t_or_off64_t (rv);
     }
   else /* file descriptor?.  */
@@ -2600,14 +2854,16 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0,
       off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
       scm_t_port *pt = SCM_PTAB_ENTRY (object);
       scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (object);
-      
+
       if (!ptob->truncate)
 	SCM_MISC_ERROR ("port is not truncatable", SCM_EOL);
+
+      scm_i_clear_pending_eof (object);
       if (pt->rw_active == SCM_PORT_READ)
 	scm_end_input_unlocked (object);
       else if (pt->rw_active == SCM_PORT_WRITE)
 	ptob->flush (object);
-      
+
       ptob->truncate (object, c_length);
       rv = 0;
     }

libguile/ports.h

@@ -4,7 +4,7 @@
 #define SCM_PORTS_H
 
 /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004,
- *   2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+ *   2006, 2008, 2009, 2010, 2011, 2012, 2013 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
@@ -48,20 +48,8 @@ typedef enum scm_t_port_rw_active {
   SCM_PORT_WRITE = 2
 } scm_t_port_rw_active;
 
-typedef enum scm_t_port_encoding_mode {
+/* An internal-only structure defined in ports-internal.h. */
-  SCM_PORT_ENCODING_MODE_UTF8,
+struct scm_port_internal;
-  SCM_PORT_ENCODING_MODE_LATIN1,
-  SCM_PORT_ENCODING_MODE_ICONV
-} scm_t_port_encoding_mode;
-
-/* This is a separate object so that only those ports that use iconv
-   cause finalizers to be registered.  */
-typedef struct scm_t_iconv_descriptors
-{
-  /* input/output iconv conversion descriptors */
-  void *input_cd;
-  void *output_cd;
-} scm_t_iconv_descriptors;
 
 /* C representation of a Scheme port.  */
 
@@ -70,6 +58,9 @@ typedef struct
   SCM port;			/* Link back to the port object.  */
   scm_i_pthread_mutex_t *lock;  /* A recursive lock for this port.  */
 
+  /* pointer to internal-only port structure */
+  struct scm_port_internal *internal;
+
   /* data for the underlying port implementation as a raw C value. */
   scm_t_bits stream;
 
@@ -129,13 +120,7 @@ typedef struct
 
   /* Character encoding support  */
   char *encoding;
-  scm_t_port_encoding_mode encoding_mode;
   scm_t_string_failed_conversion_handler ilseq_handler;
-  scm_t_iconv_descriptors *iconv_descriptors;
-
-  /* an alist for storing additional information
-     (e.g. used to store per-port read options) */
-  SCM alist;
 } scm_t_port;
 
 
@@ -305,7 +290,6 @@ SCM_INTERNAL scm_t_string_failed_conversion_handler
 scm_i_default_port_conversion_handler (void);
 SCM_INTERNAL void
 scm_i_set_default_port_conversion_handler (scm_t_string_failed_conversion_handler);
-SCM_INTERNAL scm_t_iconv_descriptors *scm_i_port_iconv_descriptors (SCM port);
 SCM_INTERNAL void scm_i_set_port_encoding_x (SCM port, const char *str);
 SCM_API SCM scm_port_encoding (SCM port);
 SCM_API SCM scm_set_port_encoding_x (SCM port, SCM encoding);
@@ -320,8 +304,10 @@ SCM_INLINE int scm_c_try_lock_port (SCM port, scm_i_pthread_mutex_t **lock);
 /* Input.  */
 SCM_API int scm_get_byte_or_eof (SCM port);
 SCM_INLINE int scm_get_byte_or_eof_unlocked (SCM port);
+SCM_API int scm_slow_get_byte_or_eof_unlocked (SCM port);
 SCM_API int scm_peek_byte_or_eof (SCM port);
 SCM_INLINE int scm_peek_byte_or_eof_unlocked (SCM port);
+SCM_API int scm_slow_peek_byte_or_eof_unlocked (SCM port);
 SCM_API size_t scm_c_read (SCM port, void *buffer, size_t size);
 SCM_API size_t scm_c_read_unlocked (SCM port, void *buffer, size_t size);
 SCM_API scm_t_wchar scm_getc (SCM port);
@@ -329,6 +315,8 @@ SCM_API scm_t_wchar scm_getc_unlocked (SCM port);
 SCM_API SCM scm_read_char (SCM port);
 
 /* Pushback.  */
+SCM_API void scm_unget_bytes (const unsigned char *buf, size_t len, SCM port);
+SCM_API void scm_unget_bytes_unlocked (const unsigned char *buf, size_t len, SCM port);
 SCM_API void scm_unget_byte (int c, SCM port);
 SCM_API void scm_unget_byte_unlocked (int c, SCM port);
 SCM_API void scm_ungetc (scm_t_wchar c, SCM port);
@@ -374,6 +362,10 @@ SCM_API SCM scm_set_port_column_x (SCM port, SCM line);
 SCM_API SCM scm_port_filename (SCM port);
 SCM_API SCM scm_set_port_filename_x (SCM port, SCM filename);
 
+/* Port alist.  */
+SCM_INTERNAL SCM scm_i_port_alist (SCM port);
+SCM_INTERNAL void scm_i_set_port_alist_x (SCM port, SCM alist);
+
 /* Implementation helpers for port printing functions.  */
 SCM_API int scm_port_print (SCM exp, SCM port, scm_print_state *);
 SCM_API void scm_print_port_mode (SCM exp, SCM port);
@@ -423,50 +415,26 @@ scm_c_try_lock_port (SCM port, scm_i_pthread_mutex_t **lock)
 SCM_INLINE_IMPLEMENTATION int
 scm_get_byte_or_eof_unlocked (SCM port)
 {
-  int c;
   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 
-  if (pt->rw_active == SCM_PORT_WRITE)
+  if (SCM_LIKELY ((pt->rw_active == SCM_PORT_READ || !pt->rw_random)
-    /* may be marginally faster than calling scm_flush.  */
+                  && pt->read_pos < pt->read_end))
-    SCM_PORT_DESCRIPTOR (port)->flush (port);
+    return *pt->read_pos++;
-
+  else
-  if (pt->rw_random)
+    return scm_slow_get_byte_or_eof_unlocked (port);
-    pt->rw_active = SCM_PORT_READ;
-
-  if (pt->read_pos >= pt->read_end)
-    {
-      if (SCM_UNLIKELY (scm_fill_input_unlocked (port) == EOF))
-	return EOF;
-    }
-
-  c = *(pt->read_pos++);
-
-  return c;
 }
 
 /* Like `scm_get_byte_or_eof' but does not change PORT's `read_pos'.  */
 SCM_INLINE_IMPLEMENTATION int
 scm_peek_byte_or_eof_unlocked (SCM port)
 {
-  int c;
   scm_t_port *pt = SCM_PTAB_ENTRY (port);
 
-  if (pt->rw_active == SCM_PORT_WRITE)
+  if (SCM_LIKELY ((pt->rw_active == SCM_PORT_READ || !pt->rw_random)
-    /* may be marginally faster than calling scm_flush.  */
+                  && pt->read_pos < pt->read_end))
-    SCM_PORT_DESCRIPTOR (port)->flush (port);
+    return *pt->read_pos;
-
+  else
-  if (pt->rw_random)
+    return scm_slow_peek_byte_or_eof_unlocked (port);
-    pt->rw_active = SCM_PORT_READ;
-
-  if (pt->read_pos >= pt->read_end)
-    {
-      if (SCM_UNLIKELY (scm_fill_input_unlocked (port) == EOF))
-	return EOF;
-    }
-
-  c = *pt->read_pos;
-
-  return c;
 }
 
 SCM_INLINE_IMPLEMENTATION void

libguile/print.c

@@ -1,5 +1,5 @@
 /* Copyright (C) 1995-1999, 2000, 2001, 2002, 2003, 2004, 2006, 2008,
- *   2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+ *   2009, 2010, 2011, 2012, 2013 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
@@ -44,6 +44,7 @@
 #include "libguile/alist.h"
 #include "libguile/struct.h"
 #include "libguile/ports.h"
+#include "libguile/ports-internal.h"
 #include "libguile/root.h"
 #include "libguile/strings.h"
 #include "libguile/strports.h"
@@ -947,8 +948,24 @@ display_string_using_iconv (const void *str, int narrow_p, size_t len,
 {
   size_t printed;
   scm_t_iconv_descriptors *id;
+  scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port);
 
-  id = scm_i_port_iconv_descriptors (port);
+  id = scm_i_port_iconv_descriptors (port, SCM_PORT_WRITE);
+
+  if (SCM_UNLIKELY (pti->at_stream_start_for_bom_write && len > 0))
+    {
+      scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+      /* Record that we're no longer at stream start.  */
+      pti->at_stream_start_for_bom_write = 0;
+      if (pt->rw_random)
+        pti->at_stream_start_for_bom_read = 0;
+
+      /* Write a BOM if appropriate.  */
+      if (SCM_UNLIKELY (strcmp(pt->encoding, "UTF-16") == 0
+                        || strcmp(pt->encoding, "UTF-32") == 0))
+        display_character (SCM_UNICODE_BOM, port, iconveh_error);
+    }
 
   printed = 0;
 
@@ -1046,13 +1063,13 @@ display_string (const void *str, int narrow_p,
 		size_t len, SCM port,
 		scm_t_string_failed_conversion_handler strategy)
 {
-  scm_t_port *pt;
+  scm_t_port_internal *pti;
 
-  pt = SCM_PTAB_ENTRY (port);
+  pti = SCM_PORT_GET_INTERNAL (port);
 
-  if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8)
+  if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8)
     return display_string_as_utf8 (str, narrow_p, len, port);
-  else if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
+  else if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
     return display_string_as_latin1 (str, narrow_p, len, port, strategy);
   else
     return display_string_using_iconv (str, narrow_p, len, port, strategy);

libguile/r6rs-ports.c

@@ -534,72 +534,41 @@ SCM_DEFINE (scm_get_bytevector_n_x, "get-bytevector-n!", 4, 0, 0,
 
 SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0,
 	    (SCM port),
-	    "Read from @var{port}, blocking as necessary, until data "
+            "Read from @var{port}, blocking as necessary, until bytes "
-	    "are available or and end-of-file is reached.  Return either "
+            "are available or an end-of-file is reached.  Return either "
-	    "a new bytevector containing the data read or the "
+            "the end-of-file object or a new bytevector containing some "
-	    "end-of-file object.")
+            "of the available bytes (at least one), and update the port "
+            "position to point just past these bytes.")
 #define FUNC_NAME s_scm_get_bytevector_some
 {
-  /* Read at least one byte, unless the end-of-file is already reached, and
+  scm_t_port *pt;
-     read while characters are available (buffered).  */
+  size_t size;
-
+  SCM bv;
-  SCM result;
-  char *c_bv;
-  unsigned c_len;
-  size_t c_total;
 
   SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+  pt = SCM_PTAB_ENTRY (port);
 
-  c_len = 4096;
+  if (pt->rw_active == SCM_PORT_WRITE)
-  c_bv = (char *) scm_gc_malloc_pointerless (c_len, SCM_GC_BYTEVECTOR);
+    scm_flush_unlocked (port);
-  c_total = 0;
 
-  do
+  if (pt->rw_random)
+    pt->rw_active = SCM_PORT_READ;
+
+  if (pt->read_pos >= pt->read_end)
     {
-      int c_chr;
+      if (scm_fill_input_unlocked (port) == EOF)
-
+	return SCM_EOF_VAL;
-      if (c_total + 1 > c_len)
-	{
-	  /* Grow the bytevector.  */
-	  c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2,
-					  SCM_GC_BYTEVECTOR);
-	  c_len *= 2;
-	}
-
-      /* We can't use `scm_c_read ()' since it blocks.  */
-      c_chr = scm_get_byte_or_eof_unlocked (port);
-      if (c_chr != EOF)
-	{
-	  c_bv[c_total] = (char) c_chr;
-	  c_total++;
-	}
-      else
-        break;
-    }
-  /* XXX: We want to check for the availability of a byte, but that's
-     what `scm_char_ready_p' actually does.  */
-  while (scm_is_true (scm_char_ready_p (port)));
-
-  if (c_total == 0)
-    {
-      result = SCM_EOF_VAL;
-      scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
-    }
-  else
-    {
-      if (c_len > c_total)
-	{
-	  /* Shrink the bytevector.  */
-	  c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total,
-					  SCM_GC_BYTEVECTOR);
-	  c_len = (unsigned) c_total;
-	}
-
-      result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len,
-                                         SCM_BOOL_F);
     }
 
-  return result;
+  size = pt->read_end - pt->read_pos;
+  if (pt->read_buf == pt->putback_buf)
+    size += pt->saved_read_end - pt->saved_read_pos;
+
+  bv = scm_c_make_bytevector (size);
+  scm_take_from_input_buffers
+    (port, (char *) SCM_BYTEVECTOR_CONTENTS (bv), size);
+
+  return bv;
 }
 #undef FUNC_NAME
 
@@ -730,6 +699,49 @@ SCM_DEFINE (scm_put_bytevector, "put-bytevector", 2, 2, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_unget_bytevector, "unget-bytevector", 2, 2, 0,
+	    (SCM port, SCM bv, SCM start, SCM count),
+	    "Unget the contents of @var{bv} to @var{port}, optionally "
+	    "starting at index @var{start} and limiting to @var{count} "
+	    "octets.")
+#define FUNC_NAME s_scm_unget_bytevector
+{
+  unsigned char *c_bv;
+  size_t c_start, c_count, c_len;
+
+  SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+  SCM_VALIDATE_BYTEVECTOR (2, bv);
+
+  c_len = SCM_BYTEVECTOR_LENGTH (bv);
+  c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+
+  if (!scm_is_eq (start, SCM_UNDEFINED))
+    {
+      c_start = scm_to_size_t (start);
+
+      if (!scm_is_eq (count, SCM_UNDEFINED))
+	{
+	  c_count = scm_to_size_t (count);
+	  if (SCM_UNLIKELY (c_start + c_count > c_len))
+	    scm_out_of_range (FUNC_NAME, count);
+	}
+      else
+	{
+	  if (SCM_UNLIKELY (c_start >= c_len))
+	    scm_out_of_range (FUNC_NAME, start);
+	  else
+	    c_count = c_len - c_start;
+	}
+    }
+  else
+    c_start = 0, c_count = c_len;
+
+  scm_unget_bytes (c_bv + c_start, c_count, port);
+
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
 
 
 /* Bytevector output port ("bop" for short).  */

libguile/read.c

@@ -29,6 +29,7 @@
 #include <unistd.h>
 #include <unicase.h>
 #include <unictype.h>
+#include <c-strcase.h>
 
 #include "libguile/_scm.h"
 #include "libguile/bytevectors.h"
@@ -42,6 +43,7 @@
 #include "libguile/hashtab.h"
 #include "libguile/hash.h"
 #include "libguile/ports.h"
+#include "libguile/ports-internal.h"
 #include "libguile/fports.h"
 #include "libguile/root.h"
 #include "libguile/strings.h"
@@ -968,7 +970,7 @@ scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
   size_t charname_len, bytes_read;
   scm_t_wchar cp;
   int overflow;
-  scm_t_port *pt;
+  scm_t_port_internal *pti;
 
   overflow = read_token (port, opts, buffer, READER_CHAR_NAME_MAX_SIZE,
                          &bytes_read);
@@ -986,14 +988,14 @@ scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
       return (SCM_MAKE_CHAR (chr));
     }
 
-  pt = SCM_PTAB_ENTRY (port);
+  pti = SCM_PORT_GET_INTERNAL (port);
 
   /* Simple ASCII characters can be processed immediately.  Also, simple
      ISO-8859-1 characters can be processed immediately if the encoding for this
      port is ISO-8859-1.  */
   if (bytes_read == 1 &&
       ((unsigned char) buffer[0] <= 127
-       || pt->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1))
+       || pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1))
     {
       SCM_COL (port) += 1;
       return SCM_MAKE_CHAR (buffer[0]);
@@ -1969,7 +1971,6 @@ scm_i_scan_for_encoding (SCM port)
   char header[SCM_ENCODING_SEARCH_SIZE+1];
   size_t bytes_read, encoding_length, i;
   char *encoding = NULL;
-  int utf8_bom = 0;
   char *pos, *encoding_start;
   int in_comment;
 
@@ -2014,10 +2015,6 @@ scm_i_scan_for_encoding (SCM port)
       scm_seek (port, scm_from_int (0), scm_from_int (SEEK_SET));
     }
 
-  if (bytes_read > 3 
-      && header[0] == '\xef' && header[1] == '\xbb' && header[2] == '\xbf')
-    utf8_bom = 1;
-
   /* search past "coding[:=]" */
   pos = header;
   while (1)
@@ -2083,11 +2080,6 @@ scm_i_scan_for_encoding (SCM port)
     /* This wasn't in a comment */
     return NULL;
 
-  if (utf8_bom && strcasecmp (encoding, "UTF-8"))
-    scm_misc_error (NULL,
-		    "the port input declares the encoding ~s but is encoded as UTF-8",
-		    scm_list_1 (scm_from_locale_string (encoding)));
-
   return encoding;
 }
 
@@ -2112,7 +2104,7 @@ SCM_DEFINE (scm_file_encoding, "file-encoding", 1, 0, 0,
     return SCM_BOOL_F;
   else
     {
-      s_enc = scm_from_locale_string (enc);
+      s_enc = scm_string_upcase (scm_from_locale_string (enc));
       return s_enc;
     }
 
@@ -2124,8 +2116,9 @@ SCM_DEFINE (scm_file_encoding, "file-encoding", 1, 0, 0,
 /* Per-port read options.
 
    We store per-port read options in the 'port-read-options' key of the
-   port's alist.  The value stored in the alist is a single integer that
+   port's alist, which is stored in the internal port structure.  The
-   contains a two-bit field for each read option.
+   value stored in the alist is a single integer that contains a two-bit
+   field for each read option.
 
    If a bit field contains READ_OPTION_INHERIT (3), that indicates that
    the applicable value should be inherited from the corresponding
@@ -2160,12 +2153,12 @@ SCM_SYMBOL (sym_port_read_options, "port-read-options");
 static void
 set_port_read_option (SCM port, int option, int new_value)
 {
-  SCM scm_read_options;
+  SCM alist, scm_read_options;
   unsigned int read_options;
 
   new_value &= READ_OPTION_MASK;
-  scm_read_options = scm_assq_ref (SCM_PTAB_ENTRY(port)->alist,
+  alist = scm_i_port_alist (port);
-                                   sym_port_read_options);
+  scm_read_options = scm_assq_ref (alist, sym_port_read_options);
   if (scm_is_unsigned_integer (scm_read_options, 0, READ_OPTIONS_MAX_VALUE))
     read_options = scm_to_uint (scm_read_options);
   else
@@ -2173,9 +2166,8 @@ set_port_read_option (SCM port, int option, int new_value)
   read_options &= ~(READ_OPTION_MASK << option);
   read_options |= new_value << option;
   scm_read_options = scm_from_uint (read_options);
-  SCM_PTAB_ENTRY(port)->alist = scm_assq_set_x (SCM_PTAB_ENTRY(port)->alist,
+  alist = scm_assq_set_x (alist, sym_port_read_options, scm_read_options);
-                                                sym_port_read_options,
+  scm_i_set_port_alist_x (port, alist);
-                                                scm_read_options);
 }
 
 /* Set OPTS and PORT's case-insensitivity according to VALUE. */
@@ -2210,11 +2202,11 @@ set_port_curly_infix_p (SCM port, scm_t_read_opts *opts, int value)
 static void
 init_read_options (SCM port, scm_t_read_opts *opts)
 {
-  SCM val, scm_read_options;
+  SCM alist, val, scm_read_options;
   unsigned int read_options, x;
 
-  scm_read_options = scm_assq_ref (SCM_PTAB_ENTRY(port)->alist,
+  alist = scm_i_port_alist (port);
-                                   sym_port_read_options);
+  scm_read_options = scm_assq_ref (alist, sym_port_read_options);
 
   if (scm_is_unsigned_integer (scm_read_options, 0, READ_OPTIONS_MAX_VALUE))
     read_options = scm_to_uint (scm_read_options);

libguile/stime.c

@@ -68,17 +68,9 @@
 # include <time.h>
 #endif
 
-#ifdef HAVE_SYS_TYPES_H
+#include <sys/types.h>
-# include <sys/types.h>
-#endif
-
-#ifdef HAVE_STRING_H
 #include <string.h>
-#endif
+#include <sys/times.h>
-
-#ifdef HAVE_SYS_TIMES_H
-# include <sys/times.h>
-#endif
 
 #ifdef HAVE_SYS_TIMEB_H
 # include <sys/timeb.h>
@@ -170,7 +162,6 @@ get_internal_real_time_gettimeofday (void)
 #endif
 
 
-#if defined HAVE_TIMES
 static long ticks_per_second;
 
 static long
@@ -181,7 +172,6 @@ get_internal_run_time_times (void)
   return (time_buffer.tms_utime + time_buffer.tms_stime)
     * TIME_UNITS_PER_SECOND / ticks_per_second;
 }
-#endif
 
 static timet fallback_real_time_base;
 static long
@@ -203,7 +193,6 @@ SCM_DEFINE (scm_get_internal_real_time, "get-internal-real-time", 0, 0, 0,
 #undef FUNC_NAME
 
 
-#ifdef HAVE_TIMES
 SCM_DEFINE (scm_times, "times", 0, 0, 0,
             (void),
 	    "Return an object with information about real and processor\n"
@@ -254,7 +243,6 @@ SCM_DEFINE (scm_times, "times", 0, 0, 0,
   return result;
 }
 #undef FUNC_NAME
-#endif /* HAVE_TIMES */
 
 long
 scm_c_get_internal_run_time (void)
@@ -869,7 +857,6 @@ scm_init_stime()
 
   /* Init ticks_per_second for scm_times, and use times(2)-based
      run-time timer if needed. */
-#ifdef HAVE_TIMES
 #ifdef _SC_CLK_TCK
   ticks_per_second = sysconf (_SC_CLK_TCK);
 #else
@@ -877,7 +864,6 @@ scm_init_stime()
 #endif
   if (!get_internal_run_time)
     get_internal_run_time = get_internal_run_time_times;
-#endif
 
   if (!get_internal_real_time)
     /* No POSIX timers, gettimeofday doesn't work... badness!  */
@@ -886,10 +872,6 @@ scm_init_stime()
       get_internal_real_time = get_internal_real_time_fallback;
     }
 
-  /* If we don't have a run-time timer, use real-time.  */
-  if (!get_internal_run_time)
-    get_internal_run_time = get_internal_real_time;
-
   scm_add_feature ("current-time");
 #include "libguile/stime.x"
 }

libguile/strings.c

@@ -29,6 +29,7 @@
 #include <uninorm.h>
 #include <unistr.h>
 #include <uniconv.h>
+#include <c-strcase.h>
 
 #include "striconveh.h"
 
@@ -36,6 +37,8 @@
 #include "libguile/chars.h"
 #include "libguile/root.h"
 #include "libguile/strings.h"
+#include "libguile/ports.h"
+#include "libguile/ports-internal.h"
 #include "libguile/error.h"
 #include "libguile/generalized-vectors.h"
 #include "libguile/deprecation.h"
@@ -1534,9 +1537,9 @@ scm_from_stringn (const char *str, size_t len, const char *encoding,
   if (len == (size_t) -1)
     len = strlen (str);
 
-  if (strcmp (encoding, "ISO-8859-1") == 0 || len == 0)
+  if (c_strcasecmp (encoding, "ISO-8859-1") == 0 || len == 0)
     return scm_from_latin1_stringn (str, len);
-  else if (strcmp (encoding, "UTF-8") == 0
+  else if (c_strcasecmp (encoding, "UTF-8") == 0
            && handler == SCM_FAILED_CONVERSION_ERROR)
     return scm_from_utf8_stringn (str, len);
 
@@ -1732,10 +1735,11 @@ SCM
 scm_from_port_stringn (const char *str, size_t len, SCM port)
 {
   scm_t_port *pt = SCM_PTAB_ENTRY (port);
+  scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port);
 
-  if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
+  if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
     return scm_from_latin1_stringn (str, len);
-  else if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8
+  else if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8
            && pt->ilseq_handler == SCM_FAILED_CONVERSION_ERROR)
     return scm_from_utf8_stringn (str, len);
   else
@@ -2137,11 +2141,12 @@ char *
 scm_to_port_stringn (SCM str, size_t *lenp, SCM port)
 {
   scm_t_port *pt = SCM_PTAB_ENTRY (port);
+  scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port);
 
-  if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1
+  if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1
       && pt->ilseq_handler == SCM_FAILED_CONVERSION_ERROR)
     return scm_to_latin1_stringn (str, lenp);
-  else if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8)
+  else if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8)
     return scm_to_utf8_stringn (str, lenp);
   else
     return scm_to_stringn (str, lenp, pt->encoding, pt->ilseq_handler);
@@ -2180,7 +2185,8 @@ scm_to_stringn (SCM str, size_t *lenp, const char *encoding,
                         "string contains #\\nul character: ~S",
                         scm_list_1 (str));
 
-  if (scm_i_is_narrow_string (str) && strcmp (encoding, "ISO-8859-1") == 0)
+  if (scm_i_is_narrow_string (str)
+      && c_strcasecmp (encoding, "ISO-8859-1") == 0)
     {
       /* If using native Latin-1 encoding, just copy the string
          contents.  */

libguile/vports.c

@@ -28,6 +28,8 @@
 #include "libguile/_scm.h"
 #include "libguile/eval.h"
 #include "libguile/chars.h"
+#include "libguile/ports.h"
+#include "libguile/ports-internal.h"
 #include "libguile/fports.h"
 #include "libguile/root.h"
 #include "libguile/strings.h"
@@ -86,15 +88,15 @@ sf_fill_input (SCM port)
 {
   SCM p = SCM_PACK (SCM_STREAM (port));
   SCM ans;
-  scm_t_port *pt;
+  scm_t_port_internal *pti;
 
   ans = scm_call_0 (SCM_SIMPLE_VECTOR_REF (p, 3)); /* get char.  */
   if (scm_is_false (ans) || SCM_EOF_OBJECT_P (ans))
     return EOF;
   SCM_ASSERT (SCM_CHARP (ans), ans, SCM_ARG1, "sf_fill_input");
-  pt = SCM_PTAB_ENTRY (port);    
+  pti = SCM_PORT_GET_INTERNAL (port);
 
-  if (pt->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
+  if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)
     {
       scm_t_port *pt = SCM_PTAB_ENTRY (port);    
       

m4/gnulib-cache.m4

@@ -27,7 +27,7 @@
 
 
 # Specification in the form of a command-line invocation:
-#   gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp fstat full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe-posix pipe2 poll putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc verify vsnprintf warnings wchar
+#   gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect dirfd duplocale environ extensions flock floor fpieee frexp fstat full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring listen localcharset locale log1p maintainer-makefile malloc-gnu malloca nl_langinfo nproc open pipe-posix pipe2 poll putenv recv recvfrom regex rename select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc verify vsnprintf warnings wchar
 
 # Specification in the form of a few gnulib-tool.m4 macro invocations:
 gl_LOCAL_DIR([gnulib-local])
@@ -39,6 +39,7 @@ gl_MODULES([
   autobuild
   bind
   byteswap
+  c-strcase
   canonicalize-lgpl
   ceil
   clock-time

meta/Makefile.am

@@ -30,9 +30,9 @@ EXTRA_DIST= \
 # What we now call `guild' used to be known as `guile-tools'.
 install-exec-hook:
 	guild="`echo $(ECHO_N) guild				\
-	   | $(SED) -e '$(program_transform_name)'`$(EXEEXT)" ;	\
+	   | $(SED) -e '$(program_transform_name)'`" ;		\
 	guile_tools="`echo $(ECHO_N) guile-tools		\
-	   | $(SED) -e '$(program_transform_name)'`$(EXEEXT)" ;	\
+	   | $(SED) -e '$(program_transform_name)'`" ;		\
 	cd $(DESTDIR)$(bindir) && rm -f "$$guile_tools" &&	\
 	$(LN_S) "$$guild" "$$guile_tools"
 

module/ice-9/binary-ports.scm

@@ -1,6 +1,6 @@
 ;;;; binary-ports.scm --- Binary IO on ports
 
-;;;;	Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;;	Copyright (C) 2009, 2010, 2011, 2013 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
@@ -40,6 +40,7 @@
             get-string-n!
             put-u8
             put-bytevector
+            unget-bytevector
             open-bytevector-output-port
             make-custom-binary-output-port))
 

module/ice-9/boot-9.scm

@@ -271,12 +271,14 @@ a-cont
 
 (define *null-device* "/dev/null")
 
+;; NOTE: Later in this file, this is redefined to support keywords
 (define (open-input-file str)
   "Takes a string naming an existing file and returns an input port
 capable of delivering characters from the file.  If the file
 cannot be opened, an error is signalled."
   (open-file str OPEN_READ))
 
+;; NOTE: Later in this file, this is redefined to support keywords
 (define (open-output-file str)
   "Takes a string naming an output file to be created and returns an
 output port capable of writing characters to a new file by that
@@ -1454,26 +1456,48 @@ CONV is not applied to the initial value."
 ;;; {High-Level Port Routines}
 ;;;
 
-(define (call-with-input-file str proc)
+(define* (open-input-file
-  "PROC should be a procedure of one argument, and STR should be a
+          file #:key (binary #f) (encoding #f) (guess-encoding #f))
-string naming a file.  The file must already exist. These procedures
+  "Takes a string naming an existing file and returns an input port
-call PROC with one argument: the port obtained by opening the named file
+capable of delivering characters from the file.  If the file
-for input or output.  If the file cannot be opened, an error is
+cannot be opened, an error is signalled."
+  (open-file file (if binary "rb" "r")
+             #:encoding encoding
+             #:guess-encoding guess-encoding))
+
+(define* (open-output-file file #:key (binary #f) (encoding #f))
+  "Takes a string naming an output file to be created and returns an
+output port capable of writing characters to a new file by that
+name.  If the file cannot be opened, an error is signalled.  If a
+file with the given name already exists, the effect is unspecified."
+  (open-file file (if binary "wb" "w")
+             #:encoding encoding))
+
+(define* (call-with-input-file
+          file proc #:key (binary #f) (encoding #f) (guess-encoding #f))
+  "PROC should be a procedure of one argument, and FILE should be a
+string naming a file.  The file must
+already exist. These procedures call PROC
+with one argument: the port obtained by opening the named file for
+input or output.  If the file cannot be opened, an error is
 signalled.  If the procedure returns, then the port is closed
-automatically and the values yielded by the procedure are returned.  If
+automatically and the values yielded by the procedure are returned.
-the procedure does not return, then the port will not be closed
+If the procedure does not return, then the port will not be closed
-automatically unless it is possible to prove that the port will never
+automatically unless it is possible to prove that the port will
-again be used for a read or write operation."
+never again be used for a read or write operation."
-  (let ((p (open-input-file str)))
+  (let ((p (open-input-file file
+                            #:binary binary
+                            #:encoding encoding
+                            #:guess-encoding guess-encoding)))
     (call-with-values
       (lambda () (proc p))
       (lambda vals
         (close-input-port p)
         (apply values vals)))))
 
-(define (call-with-output-file str proc)
+(define* (call-with-output-file file proc #:key (binary #f) (encoding #f))
-  "PROC should be a procedure of one argument, and STR should be a
+  "PROC should be a procedure of one argument, and FILE should be a
-string naming a file.  The behaviour is unspecified if the file 
+string naming a file.  The behaviour is unspecified if the file
 already exists. These procedures call PROC
 with one argument: the port obtained by opening the named file for
 input or output.  If the file cannot be opened, an error is
@@ -1482,7 +1506,7 @@ automatically and the values yielded by the procedure are returned.
 If the procedure does not return, then the port will not be closed
 automatically unless it is possible to prove that the port will
 never again be used for a read or write operation."
-  (let ((p (open-output-file str)))
+  (let ((p (open-output-file file #:binary binary #:encoding encoding)))
     (call-with-values
       (lambda () (proc p))
       (lambda vals
@@ -1501,44 +1525,52 @@ never again be used for a read or write operation."
   (parameterize ((current-error-port port))
     (thunk)))
 
-(define (with-input-from-file file thunk)
+(define* (with-input-from-file
+          file thunk #:key (binary #f) (encoding #f) (guess-encoding #f))
   "THUNK must be a procedure of no arguments, and FILE must be a
 string naming a file.  The file must already exist. The file is opened for
 input, an input port connected to it is made
-the default value returned by `current-input-port', 
+the default value returned by `current-input-port',
 and the THUNK is called with no arguments.
 When the THUNK returns, the port is closed and the previous
 default is restored.  Returns the values yielded by THUNK.  If an
 escape procedure is used to escape from the continuation of these
 procedures, their behavior is implementation dependent."
   (call-with-input-file file
-   (lambda (p) (with-input-from-port p thunk))))
+   (lambda (p) (with-input-from-port p thunk))
+   #:binary binary
+   #:encoding encoding
+   #:guess-encoding guess-encoding))
 
-(define (with-output-to-file file thunk)
+(define* (with-output-to-file file thunk #:key (binary #f) (encoding #f))
   "THUNK must be a procedure of no arguments, and FILE must be a
-string naming a file.  The effect is unspecified if the file already exists. 
+string naming a file.  The effect is unspecified if the file already exists.
 The file is opened for output, an output port connected to it is made
-the default value returned by `current-output-port', 
+the default value returned by `current-output-port',
 and the THUNK is called with no arguments.
 When the THUNK returns, the port is closed and the previous
 default is restored.  Returns the values yielded by THUNK.  If an
 escape procedure is used to escape from the continuation of these
 procedures, their behavior is implementation dependent."
   (call-with-output-file file
-   (lambda (p) (with-output-to-port p thunk))))
+   (lambda (p) (with-output-to-port p thunk))
+   #:binary binary
+   #:encoding encoding))
 
-(define (with-error-to-file file thunk)
+(define* (with-error-to-file file thunk #:key (binary #f) (encoding #f))
   "THUNK must be a procedure of no arguments, and FILE must be a
-string naming a file.  The effect is unspecified if the file already exists. 
+string naming a file.  The effect is unspecified if the file already exists.
 The file is opened for output, an output port connected to it is made
-the default value returned by `current-error-port', 
+the default value returned by `current-error-port',
 and the THUNK is called with no arguments.
 When the THUNK returns, the port is closed and the previous
 default is restored.  Returns the values yielded by THUNK.  If an
 escape procedure is used to escape from the continuation of these
 procedures, their behavior is implementation dependent."
   (call-with-output-file file
-   (lambda (p) (with-error-to-port p thunk))))
+   (lambda (p) (with-error-to-port p thunk))
+   #:binary binary
+   #:encoding encoding))
 
 (define (call-with-input-string string proc)
   "Calls the one-argument procedure @var{proc} with a newly created

module/ice-9/command-line.scm

@@ -66,7 +66,7 @@ There is NO WARRANTY, to the extent permitted by law."))
 (define* (version-etc package version #:key
                       (port (current-output-port))
                       ;; FIXME: authors
-                      (copyright-year 2012)
+                      (copyright-year 2013)
                       (copyright-holder "Free Software Foundation, Inc.")
                       (copyright (format #f "Copyright (C) ~a ~a"
                                          copyright-year copyright-holder))

module/ice-9/control.scm

@@ -1,6 +1,6 @@
 ;;; Beyond call/cc
 
-;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011, 2013 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
@@ -21,7 +21,9 @@
 (define-module (ice-9 control)
   #:re-export (call-with-prompt abort-to-prompt
                default-prompt-tag make-prompt-tag)
-  #:export (% abort shift reset shift* reset*))
+  #:export (% abort shift reset shift* reset*
+            call-with-escape-continuation call/ec
+            let-escape-continuation let/ec))
 
 (define (abort . args)
   (apply abort-to-prompt (default-prompt-tag) args))
@@ -76,3 +78,29 @@
 
 (define (shift* fc)
   (shift c (fc c)))
+
+(define (call-with-escape-continuation proc)
+  "Call PROC with an escape continuation."
+  (let ((tag (list 'call/ec)))
+    (call-with-prompt tag
+                      (lambda ()
+                        (proc (lambda args
+                                (apply abort-to-prompt tag args))))
+                      (lambda (_ . args)
+                        (apply values args)))))
+
+(define call/ec call-with-escape-continuation)
+
+(define-syntax-rule (let-escape-continuation k body ...)
+  "Bind K to an escape continuation within the lexical extent of BODY."
+  (let ((tag (list 'let/ec)))
+    (call-with-prompt tag
+                      (lambda ()
+                        (let ((k (lambda args
+                                   (apply abort-to-prompt tag args))))
+                          body ...))
+                      (lambda (_ . results)
+                        (apply values results)))))
+
+(define-syntax-rule (let/ec k body ...)
+  (let-escape-continuation k body ...))

module/ice-9/futures.scm

@@ -23,6 +23,7 @@
   #:use-module (srfi srfi-11)
   #:use-module (ice-9 q)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 control)
   #:export (future make-future future? touch))
 
 ;;; Author: Ludovic Courtès <ludo@gnu.org>
@@ -105,16 +106,6 @@ touched."
       (lambda () (begin e0 e1 ...))
       (lambda () (unlock-mutex x)))))
 
-(define-syntax-rule (let/ec k e e* ...)           ; TODO: move to core
-  (let ((tag (make-prompt-tag)))
-    (call-with-prompt
-     tag
-     (lambda ()
-       (let ((k (lambda args (apply abort-to-prompt tag args))))
-         e e* ...))
-     (lambda (_ res) res))))
-
-
 (define %future-prompt
   ;; The prompt futures abort to when they want to wait for another
   ;; future.

module/ice-9/psyntax-pp.scm

@@ -1775,50 +1775,72 @@
     'core
     'case-lambda
     (lambda (e r w s mod)
-      (let* ((tmp e)
+      (letrec*
-             (tmp ($sc-dispatch tmp '(_ . #(each (any any . each-any))))))
+        ((build-it
-        (if tmp
+           (lambda (meta clauses)
-          (apply (lambda (args e1 e2)
+             (call-with-values
-                   (call-with-values
+               (lambda () (expand-lambda-case e r w s mod lambda-formals clauses))
-                     (lambda ()
+               (lambda (meta* lcase)
-                       (expand-lambda-case
+                 (build-case-lambda s (append meta meta*) lcase))))))
-                         e
+        (let* ((tmp-1 e)
-                         r
+               (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any))))))
-                         w
+          (if tmp
-                         s
+            (apply (lambda (args e1 e2)
-                         mod
+                     (build-it
-                         lambda-formals
+                       '()
-                         (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
+                       (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
-                              e2
+                            e2
-                              e1
+                            e1
-                              args)))
+                            args)))
-                     (lambda (meta lcase) (build-case-lambda s meta lcase))))
+                   tmp)
-                 tmp)
+            (let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any . each-any))))))
-          (syntax-violation 'case-lambda "bad case-lambda" e)))))
+              (if (and tmp
+                       (apply (lambda (docstring args e1 e2) (string? (syntax->datum docstring)))
+                              tmp))
+                (apply (lambda (docstring args e1 e2)
+                         (build-it
+                           (list (cons 'documentation (syntax->datum docstring)))
+                           (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
+                                e2
+                                e1
+                                args)))
+                       tmp)
+                (syntax-violation 'case-lambda "bad case-lambda" e))))))))
   (global-extend
     'core
     'case-lambda*
     (lambda (e r w s mod)
-      (let* ((tmp e)
+      (letrec*
-             (tmp ($sc-dispatch tmp '(_ . #(each (any any . each-any))))))
+        ((build-it
-        (if tmp
+           (lambda (meta clauses)
-          (apply (lambda (args e1 e2)
+             (call-with-values
-                   (call-with-values
+               (lambda () (expand-lambda-case e r w s mod lambda*-formals clauses))
-                     (lambda ()
+               (lambda (meta* lcase)
-                       (expand-lambda-case
+                 (build-case-lambda s (append meta meta*) lcase))))))
-                         e
+        (let* ((tmp-1 e)
-                         r
+               (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any))))))
-                         w
+          (if tmp
-                         s
+            (apply (lambda (args e1 e2)
-                         mod
+                     (build-it
-                         lambda*-formals
+                       '()
-                         (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
+                       (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
-                              e2
+                            e2
-                              e1
+                            e1
-                              args)))
+                            args)))
-                     (lambda (meta lcase) (build-case-lambda s meta lcase))))
+                   tmp)
-                 tmp)
+            (let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any . each-any))))))
-          (syntax-violation 'case-lambda "bad case-lambda*" e)))))
+              (if (and tmp
+                       (apply (lambda (docstring args e1 e2) (string? (syntax->datum docstring)))
+                              tmp))
+                (apply (lambda (docstring args e1 e2)
+                         (build-it
+                           (list (cons 'documentation (syntax->datum docstring)))
+                           (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
+                                e2
+                                e1
+                                args)))
+                       tmp)
+                (syntax-violation 'case-lambda "bad case-lambda*" e))))))))
   (global-extend
     'core
     'let
@@ -3027,10 +3049,12 @@
            (lambda (fn dir k)
              (let ((p (open-input-file
                         (if (absolute-file-name? fn) fn (in-vicinity dir fn)))))
-               (let f ((x (read p)) (result '()))
+               (let ((enc (file-encoding p)))
-                 (if (eof-object? x)
+                 (set-port-encoding! p (let ((t enc)) (if t t "UTF-8")))
-                   (begin (close-input-port p) (reverse result))
+                 (let f ((x (read p)) (result '()))
-                   (f (read p) (cons (datum->syntax k x) result))))))))
+                   (if (eof-object? x)
+                     (begin (close-input-port p) (reverse result))
+                     (f (read p) (cons (datum->syntax k x) result)))))))))
         (let ((src (syntax-source x)))
           (let ((file (if src (assq-ref src 'filename) #f)))
             (let ((dir (if (string? file) (dirname file) #f)))

module/ice-9/psyntax.scm

@@ -2172,28 +2172,42 @@
 
     (global-extend 'core 'case-lambda
                    (lambda (e r w s mod)
+                     (define (build-it meta clauses)
+                       (call-with-values
+                           (lambda ()
+                             (expand-lambda-case e r w s mod
+                                                 lambda-formals
+                                                 clauses))
+                         (lambda (meta* lcase)
+                           (build-case-lambda s (append meta meta*) lcase))))
                      (syntax-case e ()
                        ((_ (args e1 e2 ...) ...)
-                        (call-with-values
+                        (build-it '() #'((args e1 e2 ...) ...)))
-                            (lambda ()
+                       ((_ docstring (args e1 e2 ...) ...)
-                              (expand-lambda-case e r w s mod
+                        (string? (syntax->datum #'docstring))
-                                                  lambda-formals
+                        (build-it `((documentation
-                                                  #'((args e1 e2 ...) ...)))
+                                     . ,(syntax->datum #'docstring)))
-                          (lambda (meta lcase)
+                                  #'((args e1 e2 ...) ...)))
-                            (build-case-lambda s meta lcase))))
                        (_ (syntax-violation 'case-lambda "bad case-lambda" e)))))
 
     (global-extend 'core 'case-lambda*
                    (lambda (e r w s mod)
+                     (define (build-it meta clauses)
+                       (call-with-values
+                           (lambda ()
+                             (expand-lambda-case e r w s mod
+                                                 lambda*-formals
+                                                 clauses))
+                         (lambda (meta* lcase)
+                           (build-case-lambda s (append meta meta*) lcase))))
                      (syntax-case e ()
                        ((_ (args e1 e2 ...) ...)
-                        (call-with-values
+                        (build-it '() #'((args e1 e2 ...) ...)))
-                            (lambda ()
+                       ((_ docstring (args e1 e2 ...) ...)
-                              (expand-lambda-case e r w s mod
+                        (string? (syntax->datum #'docstring))
-                                                  lambda*-formals
+                        (build-it `((documentation
-                                                  #'((args e1 e2 ...) ...)))
+                                     . ,(syntax->datum #'docstring)))
-                          (lambda (meta lcase)
+                                  #'((args e1 e2 ...) ...)))
-                            (build-case-lambda s meta lcase))))
                        (_ (syntax-violation 'case-lambda "bad case-lambda*" e)))))
 
     (global-extend 'core 'let
@@ -3022,10 +3036,15 @@
   (lambda (x)
     (define read-file
       (lambda (fn dir k)
-        (let ((p (open-input-file
+        (let* ((p (open-input-file
-                  (if (absolute-file-name? fn)
+                   (if (absolute-file-name? fn)
-                      fn
+                       fn
-                      (in-vicinity dir fn)))))
+                       (in-vicinity dir fn))))
+               (enc (file-encoding p)))
+
+          ;; Choose the input encoding deterministically.
+          (set-port-encoding! p (or enc "UTF-8"))
+
           (let f ((x (read p))
                   (result '()))
             (if (eof-object? x)

module/language/tree-il/peval.scm

@@ -26,6 +26,7 @@
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
+  #:use-module (ice-9 control)
   #:export (peval))
 
 ;;;
@@ -73,15 +74,6 @@
     (newline)
     (values)))
 
-(define-syntax-rule (let/ec k e e* ...)
-  (let ((tag (make-prompt-tag)))
-    (call-with-prompt
-     tag
-     (lambda ()
-       (let ((k (lambda args (apply abort-to-prompt tag args))))
-         e e* ...))
-     (lambda (_ res) res))))
-
 (define (tree-il-any proc exp)
   (let/ec k
     (tree-il-fold (lambda (exp res)

module/srfi/srfi-41.scm

@@ -27,6 +27,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-8)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
   #:export (stream-null stream-cons stream? stream-null? stream-pair?
@@ -148,7 +149,7 @@
 
 (define stream? stream-promise?)
 
-(define %stream-null '(stream . null))
+(define %stream-null (cons 'stream 'null))
 (define stream-null (stream-eager %stream-null))
 
 (define (stream-null? obj)
@@ -180,6 +181,28 @@
 (define-syntax-rule (stream-lambda formals body0 body1 ...)
   (lambda formals (stream-lazy (begin body0 body1 ...))))
 
+(define* (stream-promise-visit promise #:key on-eager on-lazy)
+  (define content (stream-promise-val promise))
+  (case (stream-value-tag content)
+    ((eager) (on-eager (stream-value-proc content)))
+    ((lazy)  (on-lazy (stream-value-proc content)))))
+
+(set-record-type-printer! stream-promise
+  (lambda (strm port)
+    (display "#<stream" port)
+    (let loop ((strm strm))
+      (stream-promise-visit strm
+        #:on-eager (lambda (pare)
+                     (cond ((eq? pare %stream-null)
+                            (write-char #\> port))
+                           (else
+                            (write-char #\space port)
+                            (stream-promise-visit (stream-kar pare)
+                              #:on-eager (cut write <> port)
+                              #:on-lazy  (lambda (_) (write-char #\? port)))
+                            (loop (stream-kdr pare)))))
+        #:on-lazy (lambda (_) (display " ...>" port))))))
+
 ;;; Derived stream functions and macros: (streams derived)
 
 (define-syntax-rule (define-stream (name . formal) body0 body1 ...)

module/srfi/srfi-45.scm

@@ -39,7 +39,8 @@
              eager
              promise?)
   #:replace (delay force promise?)
-  #:use-module (srfi srfi-9))
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu))
 
 (cond-expand-provide (current-module) '(srfi-45))
 
@@ -76,3 +77,17 @@
 ;; (*) These two lines re-fetch and check the original promise in case
 ;;     the first line of the let* caused it to be forced.  For an example
 ;;     where this happens, see reentrancy test 3 below.
+
+(define* (promise-visit promise #:key on-eager on-lazy)
+  (define content (promise-val promise))
+  (case (value-tag content)
+    ((eager) (on-eager (value-proc content)))
+    ((lazy)  (on-lazy (value-proc content)))))
+
+(set-record-type-printer! promise
+  (lambda (promise port)
+    (promise-visit promise
+      #:on-eager (lambda (value)
+                   (format port "#<promise = ~s>" value))
+      #:on-lazy  (lambda (proc)
+                   (format port "#<promise => ~s>" proc)))))

module/sxml/match.scm

@@ -20,7 +20,8 @@
             sxml-match-let
             sxml-match-let*)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-11))
+  #:use-module (srfi srfi-11)
+  #:use-module (ice-9 control))
 
 
 ;;; Commentary:
@@ -46,22 +47,6 @@
 (define-syntax-rule (void)
   *unspecified*)
 
-(define %call/ec-prompt
-  (make-prompt-tag))
-
-(define-syntax-rule (call/ec proc)
-  ;; aka. `call-with-escape-continuation'
-  (call-with-prompt %call/ec-prompt
-                    (lambda ()
-                      (proc (lambda args
-                              (apply abort-to-prompt
-                                     %call/ec-prompt args))))
-                    (lambda (_ . args)
-                      (apply values args))))
-
-(define-syntax-rule (let/ec cont body ...)
-  (call/ec (lambda (cont) body ...)))
-
 (define (raise-syntax-error x msg obj sub)
   (throw 'sxml-match-error x msg obj sub))
 

module/system/repl/repl.scm

@@ -87,12 +87,9 @@
       (lambda ()
         (let ((ch (flush-leading-whitespace)))
           (cond ((eof-object? ch)
-                 ;; EOF objects are not buffered. It's quite possible
+                 (read-char))  ; consume the EOF and return it
-                 ;; to peek an EOF then read something else. It's
-                 ;; strange but it's how it works.
-                 ch)
                 ((eqv? ch #\,)
-                 (read-char port)
+                 (read-char)
                  meta-command-token)
                 ((read-comment lang port ch)
                  *unspecified*)

test-suite/standalone/Makefile.am

@@ -204,6 +204,13 @@ test_scm_values_LDADD = $(LIBGUILE_LDADD)
 check_PROGRAMS += test-scm-values
 TESTS += test-scm-values
 
+# test-scm-c-bind-keyword-arguments
+test_scm_c_bind_keyword_arguments_SOURCES = test-scm-c-bind-keyword-arguments.c
+test_scm_c_bind_keyword_arguments_CFLAGS = ${test_cflags}
+test_scm_c_bind_keyword_arguments_LDADD = $(LIBGUILE_LDADD)
+check_PROGRAMS += test-scm-c-bind-keyword-arguments
+TESTS += test-scm-c-bind-keyword-arguments
+
 if HAVE_SHARED_LIBRARIES
 
 # test-extensions

test-suite/standalone/test-scm-c-bind-keyword-arguments.c

@@ -0,0 +1,201 @@
+/* Copyright (C) 2013 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
+ */
+
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <libguile.h>
+
+#include <assert.h>
+
+static SCM
+error_handler (void *data, SCM key, SCM args)
+{
+  SCM expected_args = scm_list_n (scm_from_utf8_string ("test"),
+                                  scm_from_utf8_string ((char *) data),
+                                  SCM_EOL, SCM_BOOL_F,
+                                  SCM_UNDEFINED);
+
+  assert (scm_is_eq (key, scm_from_utf8_symbol ("keyword-argument-error")));
+  assert (scm_is_true (scm_equal_p (args, expected_args)));
+
+  return SCM_BOOL_T;
+}
+
+static SCM
+test_unrecognized_keyword (void *data)
+{
+  SCM k_foo = scm_from_utf8_keyword ("foo");
+  SCM k_bar = scm_from_utf8_keyword ("bar");
+  SCM k_baz = scm_from_utf8_keyword ("baz");
+  SCM arg_foo, arg_bar;
+
+  scm_c_bind_keyword_arguments ("test",
+                                scm_list_n (k_foo, SCM_EOL,
+                                            k_baz, SCM_BOOL_T,
+                                            SCM_UNDEFINED),
+                                SCM_ALLOW_NON_KEYWORD_ARGUMENTS,
+                                k_foo, &arg_foo,
+                                k_bar, &arg_bar,
+                                SCM_UNDEFINED);
+  assert (0);
+}
+
+static SCM
+test_invalid_keyword (void *data)
+{
+  SCM k_foo = scm_from_utf8_keyword ("foo");
+  SCM k_bar = scm_from_utf8_keyword ("bar");
+  SCM arg_foo, arg_bar;
+
+  scm_c_bind_keyword_arguments ("test",
+                                scm_list_n (k_foo, SCM_EOL,
+                                            SCM_INUM0, SCM_INUM1,
+                                            SCM_UNDEFINED),
+                                SCM_ALLOW_OTHER_KEYS,
+                                k_foo, &arg_foo,
+                                k_bar, &arg_bar,
+                                SCM_UNDEFINED);
+  assert (0);
+}
+
+static SCM
+test_odd_length (void *data)
+{
+  SCM k_foo = scm_from_utf8_keyword ("foo");
+  SCM k_bar = scm_from_utf8_keyword ("bar");
+  SCM arg_foo, arg_bar;
+
+  scm_c_bind_keyword_arguments ("test",
+                                scm_list_n (k_foo, SCM_EOL,
+                                            SCM_INUM0,
+                                            SCM_UNDEFINED),
+                                SCM_ALLOW_OTHER_KEYS,
+                                k_foo, &arg_foo,
+                                k_bar, &arg_bar,
+                                SCM_UNDEFINED);
+  assert (0);
+}
+
+static void
+test_scm_c_bind_keyword_arguments ()
+{
+  SCM k_foo = scm_from_utf8_keyword ("foo");
+  SCM k_bar = scm_from_utf8_keyword ("bar");
+  SCM k_baz = scm_from_utf8_keyword ("baz");
+  SCM arg_foo, arg_bar;
+
+  /* All kwargs provided.  */
+  arg_foo = SCM_INUM0;
+  arg_bar = SCM_INUM1;
+  scm_c_bind_keyword_arguments ("test",
+                                scm_list_n (k_bar, SCM_EOL,
+                                            k_foo, SCM_BOOL_T,
+                                            SCM_UNDEFINED),
+                                0,
+                                k_foo, &arg_foo,
+                                k_bar, &arg_bar,
+                                SCM_UNDEFINED);
+  assert (scm_is_eq (arg_foo, SCM_BOOL_T));
+  assert (scm_is_eq (arg_bar, SCM_EOL));
+
+  /* Some kwargs provided.  */
+  arg_foo = SCM_INUM0;
+  arg_bar = SCM_INUM1;
+  scm_c_bind_keyword_arguments ("test",
+                                scm_list_n (k_bar, SCM_EOL,
+                                            SCM_UNDEFINED),
+                                0,
+                                k_foo, &arg_foo,
+                                k_bar, &arg_bar,
+                                SCM_UNDEFINED);
+  assert (scm_is_eq (arg_foo, SCM_INUM0));
+  assert (scm_is_eq (arg_bar, SCM_EOL));
+
+  /* No kwargs provided.  */
+  arg_foo = SCM_INUM0;
+  arg_bar = SCM_INUM1;
+  scm_c_bind_keyword_arguments ("test",
+                                SCM_EOL,
+                                0,
+                                k_foo, &arg_foo,
+                                k_bar, &arg_bar,
+                                SCM_UNDEFINED);
+  assert (scm_is_eq (arg_foo, SCM_INUM0));
+  assert (scm_is_eq (arg_bar, SCM_INUM1));
+
+  /* Other kwargs provided, when allowed.  */
+  arg_foo = SCM_INUM0;
+  arg_bar = SCM_INUM1;
+  scm_c_bind_keyword_arguments ("test",
+                                scm_list_n (k_foo, SCM_EOL,
+                                            k_baz, SCM_BOOL_T,
+                                            SCM_UNDEFINED),
+                                SCM_ALLOW_OTHER_KEYS,
+                                k_foo, &arg_foo,
+                                k_bar, &arg_bar,
+                                SCM_UNDEFINED);
+  assert (scm_is_eq (arg_foo, SCM_EOL));
+  assert (scm_is_eq (arg_bar, SCM_INUM1));
+
+  /* Other non-kwargs provided, when allowed.  */
+  arg_foo = SCM_INUM0;
+  arg_bar = SCM_INUM1;
+  scm_c_bind_keyword_arguments ("test",
+                                scm_list_n (SCM_BOOL_F,
+                                            k_foo, SCM_EOL,
+                                            SCM_INUM0,
+                                            k_bar, SCM_BOOL_T,
+                                            SCM_INUM1,
+                                            SCM_UNDEFINED),
+                                SCM_ALLOW_NON_KEYWORD_ARGUMENTS,
+                                k_foo, &arg_foo,
+                                k_bar, &arg_bar,
+                                SCM_UNDEFINED);
+  assert (scm_is_eq (arg_foo, SCM_EOL));
+  assert (scm_is_eq (arg_bar, SCM_BOOL_T));
+
+  /* Test unrecognized keyword error.  */
+  scm_internal_catch (SCM_BOOL_T,
+                      test_unrecognized_keyword, NULL,
+                      error_handler, "Unrecognized keyword");
+
+  /* Test invalid keyword error.  */
+  scm_internal_catch (SCM_BOOL_T,
+                      test_invalid_keyword, NULL,
+                      error_handler, "Invalid keyword");
+
+  /* Test odd length error.  */
+  scm_internal_catch (SCM_BOOL_T,
+                      test_odd_length, NULL,
+                      error_handler, "Odd length of keyword argument list");
+}
+
+static void
+tests (void *data, int argc, char **argv)
+{
+  test_scm_c_bind_keyword_arguments ();
+}
+
+int
+main (int argc, char *argv[])
+{
+  scm_boot_guile (argc, argv, tests, NULL);
+  return 0;
+}

test-suite/test-suite/lib.scm

@@ -1,6 +1,6 @@
 ;;;; test-suite/lib.scm --- generic support for testing
 ;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007, 2009, 2010,
-;;;;   2011, 2012 Free Software Foundation, Inc.
+;;;;   2011, 2012, 2013 Free Software Foundation, Inc.
 ;;;;
 ;;;; This program is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -469,13 +469,18 @@
      (with-test-prefix* prefix (lambda () body ...)))))
 
 (define-syntax c&e
-  (syntax-rules (pass-if pass-if-exception)
+  (syntax-rules (pass-if pass-if-equal pass-if-exception)
     "Run the given tests both with the evaluator and the compiler/VM."
     ((_ (pass-if test-name exp))
      (begin (pass-if (string-append test-name " (eval)")
                      (primitive-eval 'exp))
             (pass-if (string-append test-name " (compile)")
                      (compile 'exp #:to 'value #:env (current-module)))))
+    ((_ (pass-if-equal test-name val exp))
+     (begin (pass-if-equal (string-append test-name " (eval)") val
+              (primitive-eval 'exp))
+            (pass-if-equal (string-append test-name " (compile)") val
+              (compile 'exp #:to 'value #:env (current-module)))))
     ((_ (pass-if-exception test-name exc exp))
      (begin (pass-if-exception (string-append test-name " (eval)")
                                exc (primitive-eval 'exp))

test-suite/tests/00-socket.test

@@ -1,7 +1,7 @@
 ;;;; 00-socket.test --- test socket functions     -*- scheme -*-
 ;;;;
 ;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010,
-;;;;   2011, 2012 Free Software Foundation, Inc.
+;;;;   2011, 2012, 2013 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
@@ -445,6 +445,14 @@
 	    (lambda args
 	      (let ((errno (system-error-errno args)))
 		(cond ((= errno EADDRINUSE) (throw 'unresolved))
+
+                      ;; On Linux-based systems, when `ipv6' support is
+                      ;; missing (for instance, `ipv6' is loaded and
+                      ;; /proc/sys/net/ipv6/conf/all/disable_ipv6 is set
+                      ;; to 1), the socket call above succeeds but
+                      ;; bind(2) fails like this.
+                      ((= errno EADDRNOTAVAIL) (throw 'unresolved))
+
 		      (else (apply throw args)))))))
 
 	(pass-if "bind/sockaddr"
@@ -459,6 +467,7 @@
 	      (lambda args
 		(let ((errno (system-error-errno args)))
 		  (cond ((= errno EADDRINUSE) (throw 'unresolved))
+                        ((= errno EADDRNOTAVAIL) (throw 'unresolved))
 			(else (apply throw args))))))))
 
 	(pass-if "listen"

test-suite/tests/arrays.test

@@ -291,7 +291,55 @@
       (pass-if "0"      (array-fill! a 0)      #t)
       (pass-if "123"    (array-fill! a 123)    #t)
       (pass-if "-123"   (array-fill! a -123)   #t)
-      (pass-if "5/8"    (array-fill! a 5/8)    #t))))
+      (pass-if "5/8"    (array-fill! a 5/8)    #t)))
+
+  (with-test-prefix "noncompact"
+    (let* ((a (make-array 0 3 3))
+           (b (make-shared-array a (lambda (i) (list i i)) 3)))
+      (array-fill! b 9)
+      (pass-if
+        (and (equal? b #(9 9 9))
+             (equal? a #2((9 0 0) (0 9 0) (0 0 9))))))))
+
+;;;
+;;; array-copy!
+;;;
+
+(with-test-prefix "array-copy!"
+
+  (pass-if "rank 2"
+    (let ((a #2((1 2) (3 4)))
+          (b (make-array 0 2 2))
+          (c (make-array 0 2 2))
+          (d (make-array 0 2 2))
+          (e (make-array 0 2 2)))
+      (array-copy! a b)
+      (array-copy! a (transpose-array c 1 0))
+      (array-copy! (transpose-array a 1 0) d)
+      (array-copy! (transpose-array a 1 0) (transpose-array e 1 0))
+      (and (equal? a #2((1 2) (3 4)))
+           (equal? b #2((1 2) (3 4)))
+           (equal? c #2((1 3) (2 4)))
+           (equal? d #2((1 3) (2 4)))
+           (equal? e #2((1 2) (3 4))))))
+
+  (pass-if "rank 1"
+    (let* ((a #2((1 2) (3 4)))
+           (b (make-shared-array a (lambda (j) (list 1 j)) 2))
+           (c (make-shared-array a (lambda (i) (list (- 1 i) 1)) 2))
+           (d (make-array 0 2))
+           (e (make-array 0 2)))
+      (array-copy! b d)
+      (array-copy! c e)
+      (and (equal? d #(3 4))
+           (equal? e #(4 2)))))
+
+  (pass-if "rank 0"
+    (let ((a #0(99))
+          (b (make-array 0)))
+      (array-copy! a b)
+      (equal? b #0(99)))))
+
 
 ;;;
 ;;; array-in-bounds?

test-suite/tests/coding.test

@@ -1,6 +1,6 @@
 ;;;; coding.test --- test suite for coding declarations. -*- mode: scheme -*-
 ;;;;
-;;;; Copyright (C) 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2011, 2013 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
@@ -40,65 +40,65 @@
      ;; relies on the opportunistic filling of the input buffer, which
      ;; doesn't happen after a seek.
      (let* ((port (open-input-file name))
-            (res (port-encoding port)))
+            (res (file-encoding port)))
        (close-port port)
        res))))
 
 (with-test-prefix "block comments"
 
-  (pass-if "first line"
+  (pass-if-equal "first line"
-    (equal? (scan-coding "#! coding: iso-8859-1 !#")
+      "ISO-8859-1"
-            "ISO-8859-1"))
+    (scan-coding "#! coding: iso-8859-1 !#"))
-  
-  (pass-if "first line no whitespace"
-    (equal? (scan-coding "#!coding:iso-8859-1!#")
-            "ISO-8859-1"))
-  
-  (pass-if "second line"
-    (equal? (scan-coding "#!  \n  coding: iso-8859-1  !#")
-            "ISO-8859-1"))
-  
-  (pass-if "second line no whitespace"
-    (equal? (scan-coding "#!\ncoding:iso-8859-1!#")
-            "ISO-8859-1"))
-  
-  (pass-if "third line"
-    (equal? (scan-coding "#! \n  coding: iso-8859-1  \n  !#")
-            "ISO-8859-1"))
-  
-  (pass-if "third line no whitespace"
-    (equal? (scan-coding "#!\ncoding:iso-8859-1\n!#")
-            "ISO-8859-1")))
 
-(with-test-prefix "line comments"
+  (pass-if-equal "first line no whitespace"
-  (pass-if "first line, no whitespace, no nl"
+      "ISO-8859-1"
-    (equal? (scan-coding ";coding:iso-8859-1")
+    (scan-coding "#!coding:iso-8859-1!#"))
-            "ISO-8859-1"))
+
-  
+  (pass-if-equal "second line"
-  (pass-if "first line, whitespace, no nl"
+      "ISO-8859-1"
-    (equal? (scan-coding "; coding: iso-8859-1 ")
+    (scan-coding "#!  \n  coding: iso-8859-1  !#"))
-            "ISO-8859-1"))
+
-  
+  (pass-if-equal "second line no whitespace"
-  (pass-if "first line, no whitespace, nl"
+      "ISO-8859-1"
-    (equal? (scan-coding ";coding:iso-8859-1\n")
+    (scan-coding "#!\ncoding:iso-8859-1!#"))
-            "ISO-8859-1"))
+
-  
+  (pass-if-equal "third line"
-  (pass-if "first line, whitespace, nl"
+      "ISO-8859-1"
-    (equal? (scan-coding "; coding: iso-8859-1 \n")
+    (scan-coding "#! \n  coding: iso-8859-1  \n  !#"))
-            "ISO-8859-1"))
+
-  
+  (pass-if-equal "third line no whitespace"
-  (pass-if "second line, no whitespace, no nl"
+      "ISO-8859-1"
-    (equal? (scan-coding "\n;coding:iso-8859-1")
+    (scan-coding "#!\ncoding:iso-8859-1\n!#")))
-            "ISO-8859-1"))
+
-  
+(with-test-prefix "line comment"
-  (pass-if "second line, whitespace, no nl"
+  (pass-if-equal "first line, no whitespace, no nl"
-    (equal? (scan-coding "\n; coding: iso-8859-1 ")
+      "ISO-8859-1"
-            "ISO-8859-1"))
+    (scan-coding ";coding:iso-8859-1"))
-  
+
-  (pass-if "second line, no whitespace, nl"
+  (pass-if-equal "first line, whitespace, no nl"
-    (equal? (scan-coding "\n;coding:iso-8859-1\n")
+      "ISO-8859-1"
-            "ISO-8859-1"))
+    (scan-coding "; coding: iso-8859-1 "))
-  
+
-  (pass-if "second line, whitespace, nl"
+  (pass-if-equal "first line, no whitespace, nl"
-    (equal? (scan-coding "\n; coding: iso-8859-1 \n")
+      "ISO-8859-1"
-            "ISO-8859-1")))
+    (scan-coding ";coding:iso-8859-1\n"))
+
+  (pass-if-equal "first line, whitespace, nl"
+      "ISO-8859-1"
+    (scan-coding "; coding: iso-8859-1 \n"))
+
+  (pass-if-equal "second line, no whitespace, no nl"
+      "ISO-8859-1"
+    (scan-coding "\n;coding:iso-8859-1"))
+
+  (pass-if-equal "second line, whitespace, no nl"
+      "ISO-8859-1"
+    (scan-coding "\n; coding: iso-8859-1 "))
+
+  (pass-if-equal "second line, no whitespace, nl"
+      "ISO-8859-1"
+    (scan-coding "\n;coding:iso-8859-1\n"))
+
+  (pass-if-equal "second line, whitespace, nl"
+      "ISO-8859-1"
+    (scan-coding "\n; coding: iso-8859-1 \n")))

test-suite/tests/control.test

@@ -1,7 +1,7 @@
 ;;;;                                                          -*- scheme -*-
 ;;;; control.test --- test suite for delimited continuations
 ;;;;
-;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2013 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
@@ -20,6 +20,7 @@
 (define-module (test-suite test-control)
   #:use-module (ice-9 control)
   #:use-module (system vm vm)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (test-suite lib))
 
@@ -77,7 +78,32 @@
                  (abort 'foo 'bar 'baz)
                  (error "unexpected exit"))
                (lambda (k . args)
-                 args)))))
+                 args))))
+
+  (pass-if-equal "call/ec" '(0 1 2)            ; example from the manual
+    (let ((prefix
+           (lambda (x lst)
+             (call/ec
+              (lambda (return)
+                (fold (lambda (element prefix)
+                        (if (equal? element x)
+                            (return (reverse prefix))
+                            (cons element prefix)))
+                      '()
+                      lst))))))
+      (prefix 'a '(0 1 2 a 3 4 5))))
+
+  (pass-if-equal "let/ec" '(0 1 2)
+    (let ((prefix
+           (lambda (x lst)
+             (let/ec return
+               (fold (lambda (element prefix)
+                       (if (equal? element x)
+                           (return (reverse prefix))
+                           (cons element prefix)))
+                     '()
+                     lst)))))
+      (prefix 'a '(0 1 2 a 3 4 5)))))
 
 ;;; And the case in which the compiler has to reify the continuation.
 (with-test-prefix/c&e "reified continuations"

test-suite/tests/filesys.test

@@ -130,70 +130,96 @@
 
 (with-test-prefix "sendfile"
 
-  (pass-if "file"
+  (let* ((file (search-path %load-path "ice-9/boot-9.scm"))
-    (let ((file (search-path %load-path "ice-9/boot-9.scm")))
+         (len  (stat:size (stat file)))
-      (call-with-input-file file
+         (ref  (call-with-input-file file get-bytevector-all)))
-        (lambda (input)
-          (let ((len (stat:size (stat input))))
-            (call-with-output-file (test-file)
-              (lambda (output)
-                (sendfile output input len 0))))))
-      (let ((ref (call-with-input-file file get-bytevector-all))
-            (out (call-with-input-file (test-file) get-bytevector-all)))
-        (bytevector=? ref out))))
 
-  (pass-if "file with offset"
+    (pass-if-equal "file" (cons len ref)
-    (let ((file (search-path %load-path "ice-9/boot-9.scm")))
+      (let* ((result (call-with-input-file file
-      (call-with-input-file file
-        (lambda (input)
-          (let ((len (stat:size (stat input))))
-            (call-with-output-file (test-file)
-              (lambda (output)
-                (sendfile output input (- len 777) 777))))))
-      (let ((ref (call-with-input-file file
-                   (lambda (input)
-                     (seek input 777 SEEK_SET)
-                     (get-bytevector-all input))))
-            (out (call-with-input-file (test-file) get-bytevector-all)))
-        (bytevector=? ref out))))
-
-  (pass-if "pipe"
-    (if (provided? 'threads)
-        (let* ((file   (search-path %load-path "ice-9/boot-9.scm"))
-               (in+out (pipe))
-               (child  (call-with-new-thread
-                        (lambda ()
-                          (call-with-input-file file
-                            (lambda (input)
-                              (let ((len (stat:size (stat input))))
-                                (sendfile (cdr in+out) (fileno input) len 0)
-                                (close-port (cdr in+out)))))))))
-          (let ((ref (call-with-input-file file get-bytevector-all))
-                (out (get-bytevector-all (car in+out))))
-            (close-port (car in+out))
-            (bytevector=? ref out)))
-        (throw 'unresolved)))
-
-  (pass-if "pipe with offset"
-    (if (provided? 'threads)
-        (let* ((file   (search-path %load-path "ice-9/boot-9.scm"))
-               (in+out (pipe))
-               (child  (call-with-new-thread
-                        (lambda ()
-                          (call-with-input-file file
-                            (lambda (input)
-                              (let ((len (stat:size (stat input))))
-                                (sendfile (cdr in+out) (fileno input)
-                                          (- len 777) 777)
-                                (close-port (cdr in+out)))))))))
-          (let ((ref (call-with-input-file file
                        (lambda (input)
-                         (seek input 777 SEEK_SET)
+                         (call-with-output-file (test-file)
-                         (get-bytevector-all input))))
+                           (lambda (output)
-                (out (get-bytevector-all (car in+out))))
+                             (sendfile output input len 0))))))
-            (close-port (car in+out))
+             (out (call-with-input-file (test-file) get-bytevector-all)))
-            (bytevector=? ref out)))
+        (cons result out)))
-        (throw 'unresolved))))
+
+    (pass-if-equal "file with offset"
+        (cons (- len 777) (call-with-input-file file
+                            (lambda (input)
+                              (seek input 777 SEEK_SET)
+                              (get-bytevector-all input))))
+      (let* ((result (call-with-input-file file
+                       (lambda (input)
+                         (call-with-output-file (test-file)
+                           (lambda (output)
+                             (sendfile output input (- len 777) 777))))))
+             (out (call-with-input-file (test-file) get-bytevector-all)))
+        (cons result out)))
+
+    (pass-if-equal "file with offset past the end"
+        (cons (- len 777) (call-with-input-file file
+                            (lambda (input)
+                              (seek input 777 SEEK_SET)
+                              (get-bytevector-all input))))
+      (let* ((result (call-with-input-file file
+                       (lambda (input)
+                         (call-with-output-file (test-file)
+                           (lambda (output)
+                             (sendfile output input len 777))))))
+             (out (call-with-input-file (test-file) get-bytevector-all)))
+        (cons result out)))
+
+    (pass-if-equal "file with offset near the end"
+        (cons 77 (call-with-input-file file
+                   (lambda (input)
+                     (seek input (- len 77) SEEK_SET)
+                     (get-bytevector-all input))))
+      (let* ((result (call-with-input-file file
+                       (lambda (input)
+                         (call-with-output-file (test-file)
+                           (lambda (output)
+                             (sendfile output input len (- len 77)))))))
+             (out (call-with-input-file (test-file) get-bytevector-all)))
+        (cons result out)))
+
+    (pass-if-equal "pipe" (cons len ref)
+      (if (provided? 'threads)
+          (let* ((in+out (pipe))
+                 (child  (call-with-new-thread
+                          (lambda ()
+                            (call-with-input-file file
+                              (lambda (input)
+                                (let ((result (sendfile (cdr in+out)
+                                                        (fileno input)
+                                                        len 0)))
+                                  (close-port (cdr in+out))
+                                  result)))))))
+            (let ((out (get-bytevector-all (car in+out))))
+              (close-port (car in+out))
+              (cons (join-thread child) out)))
+          (throw 'unresolved)))
+
+    (pass-if-equal "pipe with offset"
+        (cons (- len 777) (call-with-input-file file
+                            (lambda (input)
+                              (seek input 777 SEEK_SET)
+                              (get-bytevector-all input))))
+      (if (provided? 'threads)
+          (let* ((in+out (pipe))
+                 (child  (call-with-new-thread
+                          (lambda ()
+                            (call-with-input-file file
+                              (lambda (input)
+                                (let ((result (sendfile (cdr in+out)
+                                                        (fileno input)
+                                                        (- len 777)
+                                                        777)))
+                                  (close-port (cdr in+out))
+                                  result)))))))
+            (let ((out (get-bytevector-all (car in+out))))
+              (close-port (car in+out))
+              (cons (join-thread child) out)))
+          (throw 'unresolved)))))
 
 (delete-file (test-file))
 (delete-file (test-symlink))

test-suite/tests/foreign.test

@@ -68,17 +68,19 @@
     (equal? (make-pointer 123) (make-pointer 123)))
 
   (pass-if "equal? modulo finalizer"
-    (let ((finalizer (dynamic-func "scm_is_pair" (dynamic-link))))
+    (let ((finalizer (false-if-exception
+                      (dynamic-func "scm_is_pair" (dynamic-link)))))
       (if (not finalizer)
-          (throw 'unresolved)                     ; probably Windows
+          (throw 'unresolved)               ;  Windows or a static build
           (equal? (make-pointer 123)
                   (make-pointer 123 finalizer)))))
 
   (pass-if "equal? modulo finalizer (set-pointer-finalizer!)"
-    (let ((finalizer (dynamic-func "scm_is_pair" (dynamic-link)))
+    (let ((finalizer (false-if-exception
+                      (dynamic-func "scm_is_pair" (dynamic-link))))
           (ptr       (make-pointer 123)))
       (if (not finalizer)
-          (throw 'unresolved)                     ; probably Windows
+          (throw 'unresolved)                ; Windows or a static build
           (begin
             (set-pointer-finalizer! ptr finalizer)
             (equal? (make-pointer 123) ptr)))))

test-suite/tests/numbers.test

@@ -1,5 +1,6 @@
 ;;;; numbers.test --- tests guile's numbers     -*- scheme -*-
-;;;; Copyright (C) 2000, 2001, 2003, 2004, 2005, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000, 2001, 2003, 2004, 2005, 2006, 2009, 2010, 2011,
+;;;;   2012, 2013 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

test-suite/tests/optargs.test

@@ -226,7 +226,15 @@
     ((case-lambda)))
 
   (pass-if-exception "no clauses, args" exception:wrong-num-args
-    ((case-lambda) 1)))
+    ((case-lambda) 1))
+
+  (pass-if "docstring"
+    (equal? "docstring test"
+            (procedure-documentation
+             (case-lambda
+              "docstring test"
+              (() 0)
+              ((x) 1))))))
 
 (with-test-prefix/c&e "case-lambda*"
   (pass-if-exception "no clauses, no args" exception:wrong-num-args
@@ -235,6 +243,14 @@
   (pass-if-exception "no clauses, args" exception:wrong-num-args
     ((case-lambda*) 1))
 
+  (pass-if "docstring"
+    (equal? "docstring test"
+            (procedure-documentation
+             (case-lambda*
+              "docstring test"
+              (() 0)
+              ((x) 1)))))
+
   (pass-if "unambiguous"
     ((case-lambda*
       ((a b) #t)

test-suite/tests/ports.test

@@ -24,7 +24,12 @@
   #:use-module (ice-9 popen)
   #:use-module (ice-9 rdelim)
   #:use-module (rnrs bytevectors)
-  #:use-module ((rnrs io ports) #:select (open-bytevector-input-port)))
+  #:use-module ((ice-9 binary-ports) #:select (open-bytevector-input-port
+                                               open-bytevector-output-port
+                                               put-bytevector
+                                               get-bytevector-n
+                                               get-bytevector-all
+                                               unget-bytevector)))
 
 (define (display-line . args)
   (for-each display args)
@@ -269,13 +274,12 @@
                    (delete-file filename)
                    (string=? line2 binary-test-string)))))
 
-;; open-file honors file coding declarations
+;; open-file ignores file coding declaration by default
-(pass-if "file: open-file honors coding declarations"
+(pass-if "file: open-file ignores coding declaration by default"
   (with-fluids ((%default-port-encoding "UTF-8"))
                (let* ((filename (test-file))
                       (port (open-output-file filename))
                       (test-string "€100"))
-                 (set-port-encoding! port "ISO-8859-15")
                  (write-line ";; coding: iso-8859-15" port)
                  (write-line test-string port)
                  (close-port port)
@@ -286,6 +290,287 @@
                    (delete-file filename)
                    (string=? line2 test-string)))))
 
+;; open-input-file with guess-encoding honors coding declaration
+(pass-if "file: open-input-file with guess-encoding honors coding declaration"
+  (with-fluids ((%default-port-encoding "UTF-8"))
+               (let* ((filename (test-file))
+                      (port (open-output-file filename))
+                      (test-string "€100"))
+                 (set-port-encoding! port "iso-8859-15")
+                 (write-line ";; coding: iso-8859-15" port)
+                 (write-line test-string port)
+                 (close-port port)
+                 (let* ((in-port (open-input-file filename
+                                                  #:guess-encoding #t))
+                        (line1 (read-line in-port))
+                        (line2 (read-line in-port)))
+                   (close-port in-port)
+                   (delete-file filename)
+                   (string=? line2 test-string)))))
+
+(with-test-prefix "keyword arguments for file openers"
+  (with-fluids ((%default-port-encoding "UTF-8"))
+    (let ((filename (test-file)))
+
+      (with-test-prefix "write #:encoding"
+
+        (pass-if-equal "open-file"
+            #vu8(116 0 101 0 115 0 116 0)
+            (let ((port (open-file filename "w"
+                                   #:encoding "UTF-16LE")))
+              (display "test" port)
+              (close-port port))
+            (let* ((port (open-file filename "rb"))
+                   (bv (get-bytevector-all port)))
+              (close-port port)
+              bv))
+
+        (pass-if-equal "open-output-file"
+            #vu8(116 0 101 0 115 0 116 0)
+            (let ((port (open-output-file filename
+                                          #:encoding "UTF-16LE")))
+              (display "test" port)
+              (close-port port))
+            (let* ((port (open-file filename "rb"))
+                   (bv (get-bytevector-all port)))
+              (close-port port)
+              bv))
+
+        (pass-if-equal "call-with-output-file"
+            #vu8(116 0 101 0 115 0 116 0)
+            (call-with-output-file filename
+              (lambda (port)
+                (display "test" port))
+              #:encoding "UTF-16LE")
+            (let* ((port (open-file filename "rb"))
+                   (bv (get-bytevector-all port)))
+              (close-port port)
+              bv))
+
+        (pass-if-equal "with-output-to-file"
+            #vu8(116 0 101 0 115 0 116 0)
+            (with-output-to-file filename
+              (lambda ()
+                (display "test"))
+              #:encoding "UTF-16LE")
+            (let* ((port (open-file filename "rb"))
+                   (bv (get-bytevector-all port)))
+              (close-port port)
+              bv))
+
+        (pass-if-equal "with-error-to-file"
+            #vu8(116 0 101 0 115 0 116 0)
+            (with-error-to-file
+             filename
+             (lambda ()
+               (display "test" (current-error-port)))
+             #:encoding "UTF-16LE")
+            (let* ((port (open-file filename "rb"))
+                   (bv (get-bytevector-all port)))
+              (close-port port)
+              bv)))
+
+      (with-test-prefix "write #:binary"
+
+        (pass-if-equal "open-output-file"
+            "ISO-8859-1"
+          (let* ((port (open-output-file filename #:binary #t))
+                 (enc (port-encoding port)))
+            (close-port port)
+            enc))
+
+        (pass-if-equal "call-with-output-file"
+            "ISO-8859-1"
+          (call-with-output-file filename port-encoding #:binary #t))
+
+        (pass-if-equal "with-output-to-file"
+            "ISO-8859-1"
+          (with-output-to-file filename
+            (lambda () (port-encoding (current-output-port)))
+            #:binary #t))
+
+        (pass-if-equal "with-error-to-file"
+            "ISO-8859-1"
+          (with-error-to-file
+           filename
+           (lambda () (port-encoding (current-error-port)))
+           #:binary #t)))
+
+      (with-test-prefix "read #:encoding"
+
+        (pass-if-equal "open-file read #:encoding"
+            "test"
+          (call-with-output-file filename
+            (lambda (port)
+              (put-bytevector port #vu8(116 0 101 0 115 0 116 0))))
+          (let* ((port (open-file filename "r" #:encoding "UTF-16LE"))
+                 (str  (read-string port)))
+            (close-port port)
+            str))
+
+        (pass-if-equal "open-input-file #:encoding"
+            "test"
+          (call-with-output-file filename
+            (lambda (port)
+              (put-bytevector port #vu8(116 0 101 0 115 0 116 0))))
+          (let* ((port (open-input-file filename #:encoding "UTF-16LE"))
+                 (str  (read-string port)))
+            (close-port port)
+            str))
+
+        (pass-if-equal "call-with-input-file #:encoding"
+            "test"
+          (call-with-output-file filename
+            (lambda (port)
+              (put-bytevector port #vu8(116 0 101 0 115 0 116 0))))
+          (call-with-input-file filename
+            read-string
+            #:encoding "UTF-16LE"))
+
+        (pass-if-equal "with-input-from-file #:encoding"
+            "test"
+          (call-with-output-file filename
+            (lambda (port)
+              (put-bytevector port #vu8(116 0 101 0 115 0 116 0))))
+          (with-input-from-file filename
+            read-string
+            #:encoding "UTF-16LE")))
+
+      (with-test-prefix "read #:binary"
+
+        (pass-if-equal "open-input-file"
+            "ISO-8859-1"
+          (let* ((port (open-input-file filename #:binary #t))
+                 (enc (port-encoding port)))
+            (close-port port)
+            enc))
+
+        (pass-if-equal "call-with-input-file"
+            "ISO-8859-1"
+          (call-with-input-file filename port-encoding #:binary #t))
+
+        (pass-if-equal "with-input-from-file"
+            "ISO-8859-1"
+          (with-input-from-file filename
+            (lambda () (port-encoding (current-input-port)))
+            #:binary #t)))
+
+      (with-test-prefix "#:guess-encoding with coding declaration"
+
+        (pass-if-equal "open-file"
+            "€100"
+          (with-output-to-file filename
+            (lambda ()
+              (write-line "test")
+              (write-line "; coding: ISO-8859-15")
+              (write-line "€100"))
+            #:encoding "ISO-8859-15")
+          (let* ((port (open-file filename "r"
+                                  #:guess-encoding #t
+                                  #:encoding "UTF-16LE"))
+                 (str (begin (read-line port)
+                             (read-line port)
+                             (read-line port))))
+            (close-port port)
+            str))
+
+        (pass-if-equal "open-input-file"
+            "€100"
+          (with-output-to-file filename
+            (lambda ()
+              (write-line "test")
+              (write-line "; coding: ISO-8859-15")
+              (write-line "€100"))
+            #:encoding "ISO-8859-15")
+          (let* ((port (open-input-file filename
+                                        #:guess-encoding #t
+                                        #:encoding "UTF-16LE"))
+                 (str (begin (read-line port)
+                             (read-line port)
+                             (read-line port))))
+            (close-port port)
+            str))
+
+        (pass-if-equal "call-with-input-file"
+            "€100"
+          (with-output-to-file filename
+            (lambda ()
+              (write-line "test")
+              (write-line "; coding: ISO-8859-15")
+              (write-line "€100"))
+            #:encoding "ISO-8859-15")
+          (call-with-input-file filename
+            (lambda (port)
+              (read-line port)
+              (read-line port)
+              (read-line port))
+            #:guess-encoding #t
+            #:encoding "UTF-16LE"))
+
+        (pass-if-equal "with-input-from-file"
+            "€100"
+          (with-output-to-file filename
+            (lambda ()
+              (write-line "test")
+              (write-line "; coding: ISO-8859-15")
+              (write-line "€100"))
+            #:encoding "ISO-8859-15")
+          (with-input-from-file filename
+            (lambda ()
+              (read-line)
+              (read-line)
+              (read-line))
+            #:guess-encoding #t
+            #:encoding "UTF-16LE")))
+
+      (with-test-prefix "#:guess-encoding without coding declaration"
+
+        (pass-if-equal "open-file"
+            "€100"
+          (with-output-to-file filename
+            (lambda () (write-line "€100"))
+            #:encoding "ISO-8859-15")
+          (let* ((port (open-file filename "r"
+                                  #:guess-encoding #t
+                                  #:encoding "ISO-8859-15"))
+                 (str (read-line port)))
+            (close-port port)
+            str))
+
+        (pass-if-equal "open-input-file"
+            "€100"
+          (with-output-to-file filename
+            (lambda () (write-line "€100"))
+            #:encoding "ISO-8859-15")
+          (let* ((port (open-input-file filename
+                                        #:guess-encoding #t
+                                        #:encoding "ISO-8859-15"))
+                 (str (read-line port)))
+            (close-port port)
+            str))
+
+        (pass-if-equal "call-with-input-file"
+            "€100"
+          (with-output-to-file filename
+            (lambda () (write-line "€100"))
+            #:encoding "ISO-8859-15")
+          (call-with-input-file filename
+            read-line
+            #:guess-encoding #t
+            #:encoding "ISO-8859-15"))
+
+        (pass-if-equal "with-input-from-file"
+            "€100"
+          (with-output-to-file filename
+            (lambda () (write-line "€100"))
+            #:encoding "ISO-8859-15")
+          (with-input-from-file filename
+            read-line
+            #:guess-encoding #t
+            #:encoding "ISO-8859-15")))
+
+      (delete-file filename))))
+
 ;;; ungetting characters and strings.
 (with-input-from-string "walk on the moon\nmoon"
 			(lambda ()
@@ -918,7 +1203,9 @@
 
   (pass-if-exception "set-port-encoding!, wrong encoding"
     exception:miscellaneous-error
-    (set-port-encoding! (open-input-string "") "does-not-exist"))
+    (let ((p (open-input-string "")))
+      (set-port-encoding! p "does-not-exist")
+      (read p)))
 
   (pass-if-exception "%default-port-encoding, wrong encoding"
     exception:miscellaneous-error
@@ -1109,6 +1396,90 @@
        (pass-if "char-ready? returns true on string port as default port"
 		(char-ready?))))))
 
+
+;;;; pending-eof behavior
+
+(with-test-prefix "pending EOF behavior"
+  ;; Make a test port that will produce the given sequence.  Each
+  ;; element of 'lst' may be either a character or #f (which means EOF).
+  (define (test-soft-port . lst)
+    (make-soft-port
+     (vector (lambda (c) #f)            ; write char
+             (lambda (s) #f)            ; write string
+             (lambda () #f)             ; flush
+             (lambda ()                 ; read char
+               (let ((c (car lst)))
+                 (set! lst (cdr lst))
+                 c))
+             (lambda () #f))            ; close
+     "rw"))
+
+  (define (call-with-port p proc)
+    (dynamic-wind
+      (lambda () #f)
+      (lambda () (proc p))
+      (lambda () (close-port p))))
+
+  (define (call-with-test-file str proc)
+    (let ((filename (test-file)))
+      (dynamic-wind
+        (lambda () (call-with-output-file filename
+                     (lambda (p) (display str p))))
+        (lambda () (call-with-input-file filename proc))
+        (lambda () (delete-file (test-file))))))
+
+  (pass-if "peek-char does not swallow EOF (soft port)"
+    (call-with-port (test-soft-port #\a #f #\b)
+      (lambda (p)
+        (and (char=? #\a  (peek-char p))
+             (char=? #\a  (read-char p))
+             (eof-object? (peek-char p))
+             (eof-object? (read-char p))
+             (char=? #\b  (peek-char p))
+             (char=? #\b  (read-char p))))))
+
+  (pass-if "unread clears pending EOF (soft port)"
+    (call-with-port (test-soft-port #\a #f #\b)
+      (lambda (p)
+        (and (char=? #\a  (read-char p))
+             (eof-object? (peek-char p))
+             (begin (unread-char #\u p)
+                    (char=? #\u  (read-char p)))))))
+
+  (pass-if "unread clears pending EOF (string port)"
+    (call-with-input-string "a"
+      (lambda (p)
+        (and (char=? #\a  (read-char p))
+             (eof-object? (peek-char p))
+             (begin (unread-char #\u p)
+                    (char=? #\u  (read-char p)))))))
+
+  (pass-if "unread clears pending EOF (file port)"
+    (call-with-test-file
+     "a"
+     (lambda (p)
+       (and (char=? #\a  (read-char p))
+            (eof-object? (peek-char p))
+            (begin (unread-char #\u p)
+                   (char=? #\u  (read-char p)))))))
+
+  (pass-if "seek clears pending EOF (string port)"
+    (call-with-input-string "a"
+      (lambda (p)
+        (and (char=? #\a  (read-char p))
+             (eof-object? (peek-char p))
+             (begin (seek p 0 SEEK_SET)
+                    (char=? #\a (read-char p)))))))
+
+  (pass-if "seek clears pending EOF (file port)"
+    (call-with-test-file
+     "a"
+     (lambda (p)
+       (and (char=? #\a  (read-char p))
+            (eof-object? (peek-char p))
+            (begin (seek p 0 SEEK_SET)
+                   (char=? #\a (read-char p))))))))
+
 
 ;;;; Close current-input-port, and make sure everyone can handle it.
 
@@ -1149,6 +1520,286 @@
 
 
 
+(pass-if-equal "unget-bytevector"
+    #vu8(10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 200 201 202 203
+            1 2 3 4 251 253 254 255)
+  (let ((port (open-bytevector-input-port #vu8(1 2 3 4 251 253 254 255))))
+    (unget-bytevector port #vu8(200 201 202 203))
+    (unget-bytevector port #vu8(20 21 22 23 24))
+    (unget-bytevector port #vu8(10 11 12 13 14 15 16 17 18 19) 4)
+    (unget-bytevector port #vu8(10 11 12 13 14 15 16 17 18 19) 2 2)
+    (unget-bytevector port #vu8(10 11))
+    (get-bytevector-all port)))
+
+
+
+(with-test-prefix "unicode byte-order marks (BOMs)"
+
+  (define (bv-read-test* encoding bv proc)
+    (let ((port (open-bytevector-input-port bv)))
+      (set-port-encoding! port encoding)
+      (proc port)))
+
+  (define (bv-read-test encoding bv)
+    (bv-read-test* encoding bv read-string))
+
+  (define (bv-write-test* encoding proc)
+    (call-with-values
+        (lambda () (open-bytevector-output-port))
+      (lambda (port get-bytevector)
+        (set-port-encoding! port encoding)
+        (proc port)
+        (get-bytevector))))
+
+  (define (bv-write-test encoding str)
+    (bv-write-test* encoding
+                    (lambda (p)
+                      (display str p))))
+
+  (pass-if-equal "BOM not discarded from Latin-1 stream"
+      "\xEF\xBB\xBF\x61"
+    (bv-read-test "ISO-8859-1" #vu8(#xEF #xBB #xBF #x61)))
+
+  (pass-if-equal "BOM not discarded from Latin-2 stream"
+      "\u010F\u0165\u017C\x61"
+    (bv-read-test "ISO-8859-2" #vu8(#xEF #xBB #xBF #x61)))
+
+  (pass-if-equal "BOM not discarded from UTF-16BE stream"
+      "\uFEFF\x61"
+    (bv-read-test "UTF-16BE" #vu8(#xFE #xFF #x00 #x61)))
+
+  (pass-if-equal "BOM not discarded from UTF-16LE stream"
+      "\uFEFF\x61"
+    (bv-read-test "UTF-16LE" #vu8(#xFF #xFE #x61 #x00)))
+
+  (pass-if-equal "BOM not discarded from UTF-32BE stream"
+      "\uFEFF\x61"
+    (bv-read-test "UTF-32BE" #vu8(#x00 #x00 #xFE #xFF
+                                       #x00 #x00 #x00 #x61)))
+
+  (pass-if-equal "BOM not discarded from UTF-32LE stream"
+      "\uFEFF\x61"
+    (bv-read-test "UTF-32LE" #vu8(#xFF #xFE #x00 #x00
+                                       #x61 #x00 #x00 #x00)))
+
+  (pass-if-equal "BOM not written to UTF-8 stream"
+      #vu8(#x61)
+    (bv-write-test "UTF-8" "a"))
+
+  (pass-if-equal "BOM not written to UTF-16BE stream"
+      #vu8(#x00 #x61)
+    (bv-write-test "UTF-16BE" "a"))
+
+  (pass-if-equal "BOM not written to UTF-16LE stream"
+      #vu8(#x61 #x00)
+    (bv-write-test "UTF-16LE" "a"))
+
+  (pass-if-equal "BOM not written to UTF-32BE stream"
+      #vu8(#x00 #x00 #x00 #x61)
+    (bv-write-test "UTF-32BE" "a"))
+
+  (pass-if-equal "BOM not written to UTF-32LE stream"
+      #vu8(#x61 #x00 #x00 #x00)
+    (bv-write-test "UTF-32LE" "a"))
+
+  (pass-if "Don't read from the port unless user asks to"
+    (let* ((p (make-soft-port
+               (vector
+                (lambda (c) #f)           ; write char
+                (lambda (s) #f)           ; write string
+                (lambda () #f)            ; flush
+                (lambda () (throw 'fail)) ; read char
+                (lambda () #f))
+               "rw")))
+      (set-port-encoding! p "UTF-16")
+      (display "abc" p)
+      (set-port-encoding! p "UTF-32")
+      (display "def" p)
+      #t))
+
+  ;; TODO: test that input and output streams are independent when
+  ;; appropriate, and linked when appropriate.
+
+  (pass-if-equal "BOM discarded from start of UTF-8 stream"
+      "a"
+    (bv-read-test "Utf-8" #vu8(#xEF #xBB #xBF #x61)))
+
+  (pass-if-equal "BOM discarded from start of UTF-8 stream after seek to 0"
+      '(#\a "a")
+    (bv-read-test* "uTf-8" #vu8(#xEF #xBB #xBF #x61)
+                   (lambda (p)
+                     (let ((c (read-char p)))
+                       (seek p 0 SEEK_SET)
+                       (let ((s (read-string p)))
+                         (list c s))))))
+
+  (pass-if-equal "Only one BOM discarded from start of UTF-8 stream"
+      "\uFEFFa"
+    (bv-read-test "UTF-8" #vu8(#xEF #xBB #xBF #xEF #xBB #xBF #x61)))
+
+  (pass-if-equal "BOM not discarded from UTF-8 stream after seek to > 0"
+      "\uFEFFb"
+    (bv-read-test* "UTF-8" #vu8(#x61 #xEF #xBB #xBF #x62)
+                   (lambda (p)
+                     (seek p 1 SEEK_SET)
+                     (read-string p))))
+
+  (pass-if-equal "BOM not discarded unless at start of UTF-8 stream"
+      "a\uFEFFb"
+    (bv-read-test "UTF-8" #vu8(#x61 #xEF #xBB #xBF #x62)))
+
+  (pass-if-equal "BOM (BE) written to start of UTF-16 stream"
+      #vu8(#xFE #xFF #x00 #x61 #x00 #x62)
+    (bv-write-test "UTF-16" "ab"))
+
+  (pass-if-equal "BOM (BE) written to UTF-16 stream after set-port-encoding!"
+      #vu8(#xFE #xFF #x00 #x61 #x00 #x62 #xFE #xFF #x00 #x63 #x00 #x64)
+    (bv-write-test* "UTF-16"
+                    (lambda (p)
+                      (display "ab" p)
+                      (set-port-encoding! p "UTF-16")
+                      (display "cd" p))))
+
+  (pass-if-equal "BOM discarded from start of UTF-16 stream (BE)"
+      "a"
+    (bv-read-test "UTF-16" #vu8(#xFE #xFF #x00 #x61)))
+
+  (pass-if-equal "BOM discarded from start of UTF-16 stream (BE) after seek to 0"
+      '(#\a "a")
+    (bv-read-test* "utf-16" #vu8(#xFE #xFF #x00 #x61)
+                   (lambda (p)
+                     (let ((c (read-char p)))
+                       (seek p 0 SEEK_SET)
+                       (let ((s (read-string p)))
+                         (list c s))))))
+
+  (pass-if-equal "Only one BOM discarded from start of UTF-16 stream (BE)"
+      "\uFEFFa"
+    (bv-read-test "Utf-16" #vu8(#xFE #xFF #xFE #xFF #x00 #x61)))
+
+  (pass-if-equal "BOM not discarded from UTF-16 stream (BE) after seek to > 0"
+      "\uFEFFa"
+    (bv-read-test* "uTf-16" #vu8(#xFE #xFF #xFE #xFF #x00 #x61)
+                   (lambda (p)
+                     (seek p 2 SEEK_SET)
+                     (read-string p))))
+
+  (pass-if-equal "BOM not discarded unless at start of UTF-16 stream"
+      "a\uFEFFb"
+    (bv-read-test "utf-16" #vu8(#x00 #x61 #xFE #xFF #x00 #x62)))
+
+  (pass-if-equal "BOM discarded from start of UTF-16 stream (LE)"
+      "a"
+    (bv-read-test "UTF-16" #vu8(#xFF #xFE #x61 #x00)))
+
+  (pass-if-equal "BOM discarded from start of UTF-16 stream (LE) after seek to 0"
+      '(#\a "a")
+    (bv-read-test* "Utf-16" #vu8(#xFF #xFE #x61 #x00)
+                   (lambda (p)
+                     (let ((c (read-char p)))
+                       (seek p 0 SEEK_SET)
+                       (let ((s (read-string p)))
+                         (list c s))))))
+
+  (pass-if-equal "Only one BOM discarded from start of UTF-16 stream (LE)"
+      "\uFEFFa"
+    (bv-read-test "UTf-16" #vu8(#xFF #xFE #xFF #xFE #x61 #x00)))
+
+  (pass-if-equal "BOM discarded from start of UTF-32 stream (BE)"
+      "a"
+    (bv-read-test "UTF-32" #vu8(#x00 #x00 #xFE #xFF
+                                     #x00 #x00 #x00 #x61)))
+
+  (pass-if-equal "BOM discarded from start of UTF-32 stream (BE) after seek to 0"
+      '(#\a "a")
+    (bv-read-test* "utF-32" #vu8(#x00 #x00 #xFE #xFF
+                                      #x00 #x00 #x00 #x61)
+                   (lambda (p)
+                     (let ((c (read-char p)))
+                       (seek p 0 SEEK_SET)
+                       (let ((s (read-string p)))
+                         (list c s))))))
+
+  (pass-if-equal "Only one BOM discarded from start of UTF-32 stream (BE)"
+      "\uFEFFa"
+    (bv-read-test "UTF-32" #vu8(#x00 #x00 #xFE #xFF
+                                     #x00 #x00 #xFE #xFF
+                                     #x00 #x00 #x00 #x61)))
+
+  (pass-if-equal "BOM not discarded from UTF-32 stream (BE) after seek to > 0"
+      "\uFEFFa"
+    (bv-read-test* "UtF-32" #vu8(#x00 #x00 #xFE #xFF
+                                      #x00 #x00 #xFE #xFF
+                                      #x00 #x00 #x00 #x61)
+                   (lambda (p)
+                     (seek p 4 SEEK_SET)
+                     (read-string p))))
+
+  (pass-if-equal "BOM discarded within UTF-16 stream (BE) after set-port-encoding!"
+      "ab"
+    (bv-read-test* "UTF-16" #vu8(#x00 #x61 #xFE #xFF #x00 #x62)
+                   (lambda (p)
+                     (let ((a (read-char p)))
+                       (set-port-encoding! p "UTF-16")
+                       (string a (read-char p))))))
+
+  (pass-if-equal "BOM discarded within UTF-16 stream (LE,BE) after set-port-encoding!"
+      "ab"
+    (bv-read-test* "utf-16" #vu8(#x00 #x61 #xFF #xFE #x62 #x00)
+                   (lambda (p)
+                     (let ((a (read-char p)))
+                       (set-port-encoding! p "UTF-16")
+                       (string a (read-char p))))))
+
+  (pass-if-equal "BOM discarded within UTF-32 stream (BE) after set-port-encoding!"
+      "ab"
+    (bv-read-test* "UTF-32" #vu8(#x00 #x00 #x00 #x61
+                                      #x00 #x00 #xFE #xFF
+                                      #x00 #x00 #x00 #x62)
+                   (lambda (p)
+                     (let ((a (read-char p)))
+                       (set-port-encoding! p "UTF-32")
+                       (string a (read-char p))))))
+
+  (pass-if-equal "BOM discarded within UTF-32 stream (LE,BE) after set-port-encoding!"
+      "ab"
+    (bv-read-test* "UTF-32" #vu8(#x00 #x00 #x00 #x61
+                                      #xFF #xFE #x00 #x00
+                                      #x62 #x00 #x00 #x00)
+                   (lambda (p)
+                     (let ((a (read-char p)))
+                       (set-port-encoding! p "UTF-32")
+                       (string a (read-char p))))))
+
+  (pass-if-equal "BOM not discarded unless at start of UTF-32 stream"
+      "a\uFEFFb"
+    (bv-read-test "UTF-32" #vu8(#x00 #x00 #x00 #x61
+                                     #x00 #x00 #xFE #xFF
+                                     #x00 #x00 #x00 #x62)))
+
+  (pass-if-equal "BOM discarded from start of UTF-32 stream (LE)"
+      "a"
+    (bv-read-test "UTF-32" #vu8(#xFF #xFE #x00 #x00
+                                     #x61 #x00 #x00 #x00)))
+
+  (pass-if-equal "BOM discarded from start of UTF-32 stream (LE) after seek to 0"
+      '(#\a "a")
+    (bv-read-test* "UTf-32" #vu8(#xFF #xFE #x00 #x00
+                                      #x61 #x00 #x00 #x00)
+                   (lambda (p)
+                     (let ((c (read-char p)))
+                       (seek p 0 SEEK_SET)
+                       (let ((s (read-string p)))
+                         (list c s))))))
+
+  (pass-if-equal "Only one BOM discarded from start of UTF-32 stream (LE)"
+      "\uFEFFa"
+    (bv-read-test "UTF-32" #vu8(#xFF #xFE #x00 #x00
+                                     #xFF #xFE #x00 #x00
+                                     #x61 #x00 #x00 #x00))))
+
+
+
 (define-syntax-rule (with-load-path path body ...)
   (let ((new path)
         (old %load-path))

test-suite/tests/r6rs-ports.test

@@ -163,30 +163,6 @@
            (equal? (bytevector->u8-list bv)
                    (map char->integer (string->list str))))))
 
-  (pass-if "get-bytevector-some [only-some]"
-    (let* ((str   "GNU Guile")
-           (index 0)
-           (port  (make-soft-port
-                   (vector #f #f #f
-                           (lambda ()
-                             (if (>= index (string-length str))
-                                 (eof-object)
-                                 (let ((c (string-ref str index)))
-                                   (set! index (+ index 1))
-                                   c)))
-                           (lambda () #t)
-                           (lambda ()
-                             ;; Number of readily available octets: falls to
-                             ;; zero after 4 octets have been read.
-                             (- 4 (modulo index 5))))
-                   "r"))
-           (bv    (get-bytevector-some port)))
-      (and (bytevector? bv)
-           (= index 4)
-           (= (bytevector-length bv) index)
-           (equal? (bytevector->u8-list bv)
-                   (map char->integer (string->list "GNU "))))))
-
   (pass-if "get-bytevector-all"
     (let* ((str   "GNU Guile")
            (index 0)

test-suite/tests/ramap.test

@@ -1,6 +1,6 @@
 ;;;; ramap.test --- test array mapping functions -*- scheme -*-
 ;;;; 
-;;;; Copyright (C) 2004, 2005, 2006, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2004, 2005, 2006, 2009, 2013 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
@@ -227,31 +227,65 @@
 
 (with-test-prefix "array-for-each"
 
+  (with-test-prefix "1 source"
+    (pass-if-equal "noncompact array"
+        '(3 2 1 0)
+      (let* ((a #2((0 1) (2 3)))
+             (l '())
+             (p (lambda (x) (set! l (cons x l)))))
+        (array-for-each p a)
+        l))
+
+    (pass-if-equal "vector"
+        '(3 2 1 0)
+      (let* ((a #(0 1 2 3))
+             (l '())
+             (p (lambda (x) (set! l (cons x l)))))
+        (array-for-each p a)
+        l))
+
+    (pass-if-equal "shared array"
+        '(3 2 1 0)
+      (let* ((a  #2((0 1) (2 3)))
+             (a' (make-shared-array a
+                                    (lambda (x)
+                                      (list (quotient x 4)
+                                            (modulo x 4)))
+                                    4))
+             (l  '())
+             (p  (lambda (x) (set! l (cons x l)))))
+        (array-for-each p a')
+        l)))
+
   (with-test-prefix "3 sources"
-    (pass-if "noncompact arrays 1"
+    (pass-if-equal "noncompact arrays 1"
+        '((3 3 3) (2 2 2))
       (let* ((a #2((0 1) (2 3)))
              (l '())
              (rec (lambda args (set! l (cons args l)))))
         (array-for-each rec (array-row a 1) (array-row a 1) (array-row a 1))
-        (equal? l '((3 3 3) (2 2 2)))))
+        l))
-          
+
-    (pass-if "noncompact arrays 2"
+    (pass-if-equal "noncompact arrays 2"
+        '((3 3 3) (2 2 1))
       (let* ((a #2((0 1) (2 3)))
              (l '())
              (rec (lambda args (set! l (cons args l)))))
         (array-for-each rec (array-row a 1) (array-row a 1) (array-col a 1))
-        (equal? l '((3 3 3) (2 2 1)))))
+        l))
-          
+
-    (pass-if "noncompact arrays 3"
+    (pass-if-equal "noncompact arrays 3"
+        '((3 3 3) (2 1 1))
       (let* ((a #2((0 1) (2 3)))
              (l '())
              (rec (lambda args (set! l (cons args l)))))
         (array-for-each rec (array-row a 1) (array-col a 1) (array-col a 1))
-        (equal? l '((3 3 3) (2 1 1)))))
+        l))
-          
+
-    (pass-if "noncompact arrays 4"
+    (pass-if-equal "noncompact arrays 4"
+        '((3 2 3) (1 0 2))
       (let* ((a #2((0 1) (2 3)))
              (l '())
              (rec (lambda args (set! l (cons args l)))))
         (array-for-each rec (array-col a 1) (array-col a 0) (array-row a 1))
-        (equal? l '((3 2 3) (1 0 2)))))))
+        l))))