diff options
| author | Mark H Weaver <mhw@netris.org> | 2013-04-14 02:48:33 -0400 |
|---|---|---|
| committer | Mark H Weaver <mhw@netris.org> | 2013-04-14 02:48:33 -0400 |
| commit | f6f4feb0a2222efcb297e634603621126542e63f (patch) | |
| tree | 0b590c025f688ab625827c4f692fa7783716b558 | |
| parent | 1e051065628a7f1bd4398fcc11cd181f86084629 (diff) | |
| parent | f5b2eea6a39507ecf6a8ecc62cc1c796c45c2d1d (diff) | |
| download | guile-f6f4feb0a2222efcb297e634603621126542e63f.tar.gz | |
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
67 files changed, 3076 insertions, 1105 deletions
@@ -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 +* Notable changes -file name docs +** New keyword arguments for procedures that open files -gnulib version +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'. ---language docs +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. -* Notable changes +See "File Ports" in the manual for details. -** New guile.m4. +** 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 -modules were imported from Gnulib: select, times, pipe-posix, fstat, -getlogin, and poll. +`number->string' now reliably outputs enough digits to produce the same +number when read back in. Previously, it mishandled subnormal numbers +(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. + +`sqrt' now produces exact rational results when possible, and handles +very large or very small numbers more robustly. -** New optimizations. +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 -them GCD and logarithms. +`string-join' now handles huge lists efficiently. + +`get-bytevector-some' now uses buffered input, which is much faster. + +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 -Finally, `array-ref' and `array-set!' on arrays of rank 1 or 2 is now -faster, because it avoids building a rest list. +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. -** `include' resolves relative file names relative to including file. +** 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 -class hierarchy diagram has been regenerated for the web and print -output formats. +`program-lambda-list' functions are now documented, as well as `and=>', +`exit', and `quit'. The (system repl server) module is now documented +(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,72 +182,122 @@ 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 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'. + +** Much more capable `xml->sxml' + +See "Reading and Writing XML" for information on how the `xml->sxml' +parser deals with namespaces, processed entities, doctypes, and literal +strings. Incidentally, `current-ssax-error-port' is now a parameter +object. + +** 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. + +** Escape continuations with `call/ec' and `let/ec' -** New procedure `sendfile'. +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 procedures for dealing with file names. +** 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 XXX for documentation on `system-file-name-convention', +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. +** `array-length', an array's first dimension See "Array Procedures". -** `hash-count', for hash tables. +** `hash-count', for hash tables See "Hash Tables". -** New foreign types: `ssize_t', `ptrdiff_t'. +** `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'. +** New C helpers: `scm_from_ptrdiff_t', `scm_to_ptrdiff_t' See "Integers". -** Much more capable `xml->sxml' - -See "Reading and Writing XML" for information on how the `xml->sxml' -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' +** Socket option `SO_REUSEPORT' now available from Scheme -See XXX in the manual. +If supported on the platform, `SO_REUSEPORT' is now available from +Scheme as well. See "Network Sockets and Communication". -** `current-language' in default environment. +** `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 - -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. +** 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) @@ -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 @@ -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 diff --git a/build-aux/gendocs.sh b/build-aux/gendocs.sh index e4bfc9fd2..e4bfc9fd2 100644..100755 --- a/build-aux/gendocs.sh +++ b/build-aux/gendocs.sh diff --git a/configure.ac b/configure.ac index 60aa49f31..3cbd960ff 100644 --- a/configure.ac +++ b/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 \ - readdir_r readdir64_r readlink rename rmdir select setegid seteuid \ - setlocale setpgid setsid sigaction siginterrupt stat64 strftime \ - strptime symlink sync sysconf tcgetpgrp tcsetpgrp times uname waitpid \ + gettimeofday gmtime_r ioctl lstat mkdir mknod nice \ + readdir_r readdir64_r readlink rename rmdir setegid seteuid \ + setlocale setpgid setsid sigaction siginterrupt stat64 \ + 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 diff --git a/doc/guile-api.alist b/doc/guile-api.alist index 5830c917a..78d3a5cd0 100644 --- a/doc/guile-api.alist +++ b/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)) diff --git a/doc/ref/api-binding.texi b/doc/ref/api-binding.texi index 5763f36de..e3a991871 100644 --- a/doc/ref/api-binding.texi +++ b/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))) diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index 641245a21..699e7601c 100644 --- a/doc/ref/api-compound.texi +++ b/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 -a simple and efficient syntactic abstraction of record types and their -associated type predicate, fields, and field accessors. SRFI-9 is +implemented by most Scheme implementations (@pxref{SRFI-9 Records}). It +defines a simple and efficient syntactic abstraction of record types and +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} diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi index 4dede7260..f34074ec6 100644 --- a/doc/ref/api-control.texi +++ b/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 diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index e3c94e215..760318028 100644 --- a/doc/ref/api-data.texi +++ b/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 -@code{scm_from_latin1_string}, @code{scm_from_utf8_string} or -@code{scm_from_utf32_string}. +match that of the execution character set, used for string and character +constants. Most modern C compilers use UTF-8 by default, so to convert +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) -@deftypefnx {C Function} scm_from_utf8_symbol (const char *name) +@deftypefn {C Function} SCM scm_from_latin1_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) -@deftypefnx {C Function} scm_from_locale_symboln (const char *name, size_t len) +@deftypefn {C Function} SCM scm_from_locale_symbol (const char *name) +@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 -@code{scm_from_latin1_symbol} or @code{scm_from_utf8_symbol}. +will match that of the execution character set, used for string and +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 -@code{scm_from_latin1_keyword} or @code{scm_from_utf8_keyword}. +will match that of the execution character set, used for string and +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 diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index 7afbcfaef..63b1d6059 100644 --- a/doc/ref/api-evaluation.texi +++ b/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 -built-in reader can interpret other character encodings. The -procedure @code{primitive-load}, and by extension the functions that -call it, such as @code{load}, first scan the top 500 characters of the -file for a coding declaration. +Scheme source code files are usually encoded in ASCII or UTF-8, but the +built-in reader can interpret other character encodings as well. When +Guile loads Scheme source code, it uses the @code{file-encoding} +procedure (described below) to try to guess the encoding of the file. +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 -@code{#!} comment. +scheme comment. It can either be a semicolon-initiated comment, or the +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 -top of the contents of a port with random-accessible contents -(@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. Return a -string containing the character encoding of the file if a declaration -was found, or @code{#f} otherwise. The port is rewound. +Attempt to scan the first few hundred bytes from the @var{port} for +hints about its character encoding. Return a string containing the +encoding name or @code{#f} if the encoding cannot be determined. The +port is rewound. + +Currently, the only supported method is to look for an Emacs-like +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 diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 11ae5803a..4c42de8d0 100644 --- a/doc/ref/api-io.texi +++ b/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 -encoding. @xref{Ports}, for more information on port encodings. +character encoding "ISO-8859-1", ignoring the default port encoding. +@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 -requested, @code{open-file} throws an exception. +Unless binary mode is requested, the character encoding of the new port +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. + +If a file cannot be opened with the access requested, @code{open-file} +throws an exception. + +When the file is opened, its encoding is set to the current +@code{%default-port-encoding}, unless the @code{b} flag was supplied. +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}}): -When the file is opened, this procedure will scan for a coding -declaration (@pxref{Character Encoding of Source Files}). If a coding -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 -file in binary mode and then set the port encoding explicitly using -@code{set-port-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 -Open @var{filename} for input. Equivalent to +@deffn {Scheme Procedure} open-input-file filename @ + [#: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 -Open @var{filename} for output. Equivalent to +@deffn {Scheme Procedure} open-output-file filename @ + [#: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 -@deffnx {Scheme Procedure} call-with-output-file filename proc +@deffn {Scheme Procedure} call-with-input-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 -@deffnx {Scheme Procedure} with-output-to-file filename thunk -@deffnx {Scheme Procedure} with-error-to-file filename thunk +@deffn {Scheme Procedure} with-input-from-file filename thunk @ + [#:guess-encoding=#f] [#:encoding=#f] [#:binary=#f] +@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 -@code{(ice-9 binary-ports)} module. It contains binary input/output -procedures and does not rely on R6RS support. +A subset of the @code{(rnrs io ports)} module, plus one non-standard +procedure @code{unget-bytevector} (@pxref{R6RS Binary Input}), is +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 -and end-of-file is reached. Return either a new bytevector containing -the data read or the end-of-file object. +Read from @var{port}, blocking as necessary, until bytes are available +or an end-of-file is reached. Return either the end-of-file object or a +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: diff --git a/doc/ref/api-modules.texi b/doc/ref/api-modules.texi index 4a4011d20..286a37d7e 100644 --- a/doc/ref/api-modules.texi +++ b/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 -Guile Modules}). +@code{close-pipe}, @code{open-input-pipe}, and so on (@pxref{Pipes}). 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 diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi index 8ff240a14..e11479dc2 100644 --- a/doc/ref/api-procedures.texi +++ b/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)) diff --git a/doc/ref/guile-invoke.texi b/doc/ref/guile-invoke.texi index 90922f27d..207c6f379 100644 --- a/doc/ref/guile-invoke.texi +++ 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 diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index e20309000..40c20e7e9 100644 --- a/doc/ref/posix.texi +++ b/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 diff --git a/doc/ref/r6rs.texi b/doc/ref/r6rs.texi index b18377135..9c5984b39 100644 --- a/doc/ref/r6rs.texi +++ b/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 diff --git a/doc/release.org b/doc/release.org index 95ba12e3b..875ec27ff 100644 --- a/doc/release.org +++ b/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 ---version' reports the new version number. +notices the new tag. Make sure you have configured with all options +enabled (Readline, --enable-deprecated, etc.) -The reason for running "make dist" instead of "make distcheck" is that -it's much faster and any distribution issues should have been caught by -Hydra already. +After "make distcheck", double-check that `./configure --version' +reports the new version number. ** 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 diff --git a/lib/Makefile.am b/lib/Makefile.am index fdcd45d2f..8857a90ce 100644 --- a/lib/Makefile.am +++ b/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 diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 6f914e060..6c9d79540 100644 --- a/libguile/Makefile.am +++ b/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 diff --git a/libguile/array-map.c b/libguile/array-map.c index c0f0f00bc..e47fb5641 100644 --- a/libguile/array-map.c +++ b/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); - - for (i = base; n--; i += inc) - GVSET (ra, i, fill); - - return 1; -} -#undef FUNC_NAME - - -static int +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; - unsigned long i_d, i_s = SCM_I_ARRAY_BASE (src); + scm_t_array_handle h_s, h_d; + size_t i_s, i_d; + ssize_t inc_s, inc_d; + dst = SCM_CAR (dst); - inc_d = SCM_I_ARRAY_DIMS (dst)->inc; - i_d = SCM_I_ARRAY_BASE (dst); - src = SCM_I_ARRAY_V (src); - dst = SCM_I_ARRAY_V (dst); + scm_array_get_handle (SCM_I_ARRAY_V (src), &h_s); + scm_array_get_handle (SCM_I_ARRAY_V (dst), &h_d); + + 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; - long inc = SCM_I_ARRAY_DIMS (ra0)->inc; - long n = SCM_I_ARRAY_DIMS (ra0)->ubnd; - long base = SCM_I_ARRAY_BASE (ra0) - i * inc; - ra0 = SCM_I_ARRAY_V (ra0); + ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd; + size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1; + + scm_t_array_handle h0; + 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++) - GVSET (ra0, i*inc+base, scm_call_0 (proc)); + for (; i0 < i0end; i0 += inc0) + h0.impl->vset (&h0, i0, scm_call_0 (proc)); else { SCM ra1 = SCM_CAR (ras); - SCM args; - unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1); - long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_I_ARRAY_V (ra1); - ras = scm_vector (SCM_CDR (ras)); - - for (; i <= n; i++, i1 += inc1) - { - 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_cons (GVREF (ra1, i1), args); - GVSET (ra0, i*inc+base, scm_apply_0 (proc, args)); - } + scm_t_array_handle h1; + size_t i1; + ssize_t inc1; + scm_array_get_handle (SCM_I_ARRAY_V (ra1), &h1); + 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; + ras = SCM_CDR (ras); + if (scm_is_null (ras)) + for (; i0 < i0end; i0 += inc0, i1 += inc1) + h0.impl->vset (&h0, i0, scm_call_1 (proc, h1.impl->vref (&h1, i1))); + else + { + 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; - unsigned long i0 = SCM_I_ARRAY_BASE (ra0); - long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; - long n = SCM_I_ARRAY_DIMS (ra0)->ubnd; - ra0 = SCM_I_ARRAY_V (ra0); + ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd; + size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1; + + scm_t_array_handle h0; + 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) - scm_call_1 (proc, GVREF (ra0, i0)); + for (; i0 < i0end; i0 += inc0) + scm_call_1 (proc, h0.impl->vref (&h0, i0)); else { - SCM ra1 = SCM_CAR (ras); - SCM args; - unsigned long k, i1 = SCM_I_ARRAY_BASE (ra1); - long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_I_ARRAY_V (ra1); - ras = scm_vector (SCM_CDR (ras)); - - for (; i <= n; i++, i0 += inc0, i1 += inc1) - { - 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); - } + ras = scm_vector (ras); + for (; i0 < i0end; i0 += inc0, ++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); + scm_apply_1 (proc, h0.impl->vref (&h0, i0), 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" diff --git a/libguile/array-map.h b/libguile/array-map.h index 43d2a9281..b0592d818 100644 --- a/libguile/array-map.h +++ b/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 */ /* diff --git a/libguile/filesys.c b/libguile/filesys.c index 09a0de0e9..1893c02cd 100644 --- a/libguile/filesys.c +++ b/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, - c_count); + { + off_t *offset_ptr; + + 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); - if (obtained < asked) + written = full_write (out_fd, buf, obtained); + 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 } diff --git a/libguile/fports.c b/libguile/fports.c index 067c3e2b5..13d1dd732 100644 --- a/libguile/fports.c +++ b/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_byte (drained[ndrained], port); + scm_unget_bytes ((unsigned char *) 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 - * Return a new port open on a given file. - * - * The mode string must match the pattern: [rwa+]** which - * is interpreted in the usual unix way. - * - * Return the new port. - */ -SCM_DEFINE (scm_open_file, "open-file", 2, 0, 0, - (SCM filename, SCM mode), - "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 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 + The mode string must match the pattern: [rwa+]** which + is interpreted in the usual unix way. + + Unless binary mode is requested, the character encoding of the new + port is determined as follows: First, if GUESS_ENCODING is true, + 'file-encoding' is used to guess the encoding of the file. If + 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 + is used. It is an error to pass a non-false GUESS_ENCODING or + ENCODING if binary mode is requested. + + Return the new port. */ +SCM +scm_open_file_with_encoding (SCM filename, SCM mode, + SCM guess_encoding, SCM encoding) +#define FUNC_NAME "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 - encoding. */ - if (SCM_INPUT_PORT_P (port)) - { - char *enc = scm_i_scan_for_encoding (port); - if (enc != NULL) - scm_i_set_port_encoding_x (port, enc); - } + if (scm_is_true (encoding)) + scm_misc_error (FUNC_NAME, + "Encoding specified on a binary port", + scm_list_1 (encoding)); + if (scm_is_true (guess_encoding)) + scm_misc_error (FUNC_NAME, + "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. */ - scm_i_set_port_encoding_x (port, NULL); + { + char *enc = 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 () { diff --git a/libguile/fports.h b/libguile/fports.h index 4094f14cd..092b43ee8 100644 --- a/libguile/fports.h +++ b/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 */ diff --git a/libguile/gc.h b/libguile/gc.h index b1df82df5..085778118 100644 --- a/libguile/gc.h +++ b/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" diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c index d8dea7f54..11020cfb2 100644 --- a/libguile/gen-scmconfig.c +++ b/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'" diff --git a/libguile/init.c b/libguile/init.c index fb952f2d1..6787483ed 100644 --- a/libguile/init.c +++ b/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 */ diff --git a/libguile/keywords.c b/libguile/keywords.c index e4a79ac4d..96c0b0144 100644 --- a/libguile/keywords.c +++ b/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 () diff --git a/libguile/keywords.h b/libguile/keywords.h index c9e6af14b..3cdb0ecdd 100644 --- a/libguile/keywords.h +++ b/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 */ diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h new file mode 100644 index 000000000..bff89cb5e --- /dev/null +++ b/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 diff --git a/libguile/ports.c b/libguile/ports.c index 31d338efe..20c90810d 100644 --- a/libguile/ports.c +++ b/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; + + pti->at_stream_start_for_bom_read = 1; + pti->at_stream_start_for_bom_write = 1; - entry->alist = SCM_EOL; + 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); - p->iconv_descriptors = NULL; + close_iconv_descriptors (pti->iconv_descriptors); + pti->iconv_descriptors = NULL; } return scm_from_bool (rv >= 0); @@ -975,6 +1007,66 @@ scm_i_set_default_port_conversion_handler (scm_t_string_failed_conversion_handle } 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) { close_iconv_descriptors (ptr); @@ -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; - - pt = SCM_PTAB_ENTRY (port); + scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); - assert (pt->encoding_mode == SCM_PORT_ENCODING_MODE_ICONV); + assert (pti->encoding_mode == SCM_PORT_ENCODING_MODE_ICONV); - if (!pt->iconv_descriptors) + if (!pti->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; - pt->iconv_descriptors = NULL; + pti->encoding_mode = SCM_PORT_ENCODING_MODE_UTF8; } else if (encoding_matches (encoding, "ISO-8859-1")) { pt->encoding = "ISO-8859-1"; - pt->encoding_mode = SCM_PORT_ENCODING_MODE_LATIN1; - pt->iconv_descriptors = NULL; + pti->encoding_mode = SCM_PORT_ENCODING_MODE_LATIN1; } else { - /* Open descriptors before mutating the port. */ - char *gc_encoding = canonicalize_encoding (encoding); - 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; + pt->encoding = canonicalize_encoding (encoding); + pti->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 - requested number of bytes. (Note that a single scm_fill_input - call does not guarantee to fill the whole of the port's read - buffer.) */ + /* Now we will call scm_i_fill_input_unlocked repeatedly until we have + read the requested number of bytes. (Note that a single + scm_i_fill_input_unlocked call does not guarantee to fill the whole + 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 - not have its own persistent buffer - but we have a buffer, - provided by our caller, that is the right size for the data - that is wanted. For the following scm_fill_input calls, - therefore, we use the buffer in hand as the port's read - buffer. - - We need to make sure that the port's normal (1 byte) buffer - is reinstated in case one of the scm_fill_input () calls - throws an exception; we use the scm_dynwind_* API to achieve - that. + /* The port that we are reading from is unbuffered - i.e. does not + have its own persistent buffer - but we have a buffer, provided + by our caller, that is the right size for the data that is + wanted. For the following scm_i_fill_input_unlocked calls, + therefore, we use the buffer in hand as the port's read buffer. + + We need to make sure that the port's normal (1 byte) buffer is + reinstated in case one of the scm_i_fill_input_unlocked () + calls throws an exception; we use the scm_dynwind_* API to + 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, - or we hit EOF. */ - while (pt->read_buf_size && (scm_fill_input_unlocked (port) != EOF)) + /* Call scm_i_fill_input_unlocked until we have all the bytes that + we need, or we hit 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, - bytes_consumed = 0, err = 0; - err == 0 && output_size == 0 - && (bytes_consumed == 0 || byte_read != EOF); - bytes_consumed++) + for (;;) { - 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) - { - *codepoint = (scm_t_wchar) EOF; - *len = 0; - return 0; - } - else - continue; + if (SCM_LIKELY (input_size == 0)) + { + *codepoint = (scm_t_wchar) EOF; + *len = input_size; + return 0; + } + else + { + /* 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; - if (err == EINVAL) - /* Missing input: keep trying. */ - err = 0; + int err = errno; + if (SCM_LIKELY (err == EINVAL)) + /* The input byte sequence did not form a complete + character. Read another byte and try again. */ + continue; + else + return err; } else - output_size = sizeof (utf8_buf) - output_left; - } - - 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; + { + 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; + } + } } - - 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) -#define FUNC_NAME "scm_unget_byte" + +static void +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) - /* 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; - 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; + scm_i_clear_pending_eof (port); - memmove (pt->read_buf + 1, pt->read_pos, count); - pt->read_end = pt->read_buf + 1 + count; - } - - pt->read_pos = pt->read_buf; - } - else + if (pt->read_buf != pt->putback_buf) /* 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 = SCM_INITIAL_PUTBACK_BUF_SIZE; + (pt->putback_buf_size, "putback buffer"); } 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; - pt->read_end = pt->read_buf + 1; + /* Put read_pos at the end of the buffer, so that ungets will not + 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 +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_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_unget_byte_unlocked (c, port); + 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_unget_byte_unlocked (result[i], port); + scm_i_unget_bytes_unlocked ((unsigned char *) result, len, 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_unget_byte_unlocked (bytes[i], port); + scm_i_unget_bytes_unlocked ((unsigned char *) bytes, len, 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 -scm_fill_input_unlocked (SCM port) +static int +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; } diff --git a/libguile/ports.h b/libguile/ports.h index c1ba71921..806448980 100644 --- a/libguile/ports.h +++ b/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 { - SCM_PORT_ENCODING_MODE_UTF8, - 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; +/* An internal-only structure defined in ports-internal.h. */ +struct scm_port_internal; /* 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) - /* may be marginally faster than calling scm_flush. */ - SCM_PORT_DESCRIPTOR (port)->flush (port); - - if (pt->rw_random) - 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; + if (SCM_LIKELY ((pt->rw_active == SCM_PORT_READ || !pt->rw_random) + && pt->read_pos < pt->read_end)) + return *pt->read_pos++; + else + return scm_slow_get_byte_or_eof_unlocked (port); } /* 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) - /* may be marginally faster than calling scm_flush. */ - SCM_PORT_DESCRIPTOR (port)->flush (port); - - if (pt->rw_random) - 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; + if (SCM_LIKELY ((pt->rw_active == SCM_PORT_READ || !pt->rw_random) + && pt->read_pos < pt->read_end)) + return *pt->read_pos; + else + return scm_slow_peek_byte_or_eof_unlocked (port); } SCM_INLINE_IMPLEMENTATION void diff --git a/libguile/print.c b/libguile/print.c index 5d5c56d2f..652409134 100644 --- a/libguile/print.c +++ b/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); diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index 7d070514b..c6ad90a53 100644 --- a/libguile/r6rs-ports.c +++ b/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 " - "are available or and end-of-file is reached. Return either " - "a new bytevector containing the data read or the " - "end-of-file object.") + "Read from @var{port}, blocking as necessary, until bytes " + "are available or an end-of-file is reached. Return either " + "the end-of-file object or a new bytevector containing some " + "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 - read while characters are available (buffered). */ - - SCM result; - char *c_bv; - unsigned c_len; - size_t c_total; + scm_t_port *pt; + size_t size; + SCM bv; SCM_VALIDATE_BINARY_INPUT_PORT (1, port); + pt = SCM_PTAB_ENTRY (port); - c_len = 4096; - c_bv = (char *) scm_gc_malloc_pointerless (c_len, SCM_GC_BYTEVECTOR); - c_total = 0; + if (pt->rw_active == SCM_PORT_WRITE) + scm_flush_unlocked (port); - do - { - int c_chr; + if (pt->rw_random) + pt->rw_active = SCM_PORT_READ; - 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) + if (pt->read_pos >= pt->read_end) { - result = SCM_EOF_VAL; - scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR); + if (scm_fill_input_unlocked (port) == EOF) + return SCM_EOF_VAL; } - 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); - } + size = pt->read_end - pt->read_pos; + if (pt->read_buf == pt->putback_buf) + size += pt->saved_read_end - pt->saved_read_pos; - return result; + 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). */ diff --git a/libguile/read.c b/libguile/read.c index 7c003b4e1..c8db81277 100644 --- a/libguile/read.c +++ b/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 - contains a two-bit field for each read option. + port's alist, which is stored in the internal port structure. The + 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, - sym_port_read_options); + alist = scm_i_port_alist (port); + 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, - sym_port_read_options, - scm_read_options); + alist = scm_assq_set_x (alist, sym_port_read_options, scm_read_options); + scm_i_set_port_alist_x (port, alist); } /* 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, - sym_port_read_options); + alist = scm_i_port_alist (port); + 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); diff --git a/libguile/stime.c b/libguile/stime.c index 90de697e5..78539d9cd 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -68,17 +68,9 @@ # include <time.h> #endif -#ifdef HAVE_SYS_TYPES_H -# include <sys/types.h> -#endif - -#ifdef HAVE_STRING_H +#include <sys/types.h> #include <string.h> -#endif - -#ifdef HAVE_SYS_TIMES_H -# include <sys/times.h> -#endif +#include <sys/times.h> #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" } diff --git a/libguile/strings.c b/libguile/strings.c index 23a1a7042..fa97a0057 100644 --- a/libguile/strings.c +++ b/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. */ diff --git a/libguile/vports.c b/libguile/vports.c index a886e362e..e7263302b 100644 --- a/libguile/vports.c +++ b/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); diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index d6dd66d3d..81e464632 100644 --- a/m4/gnulib-cache.m4 +++ b/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 diff --git a/meta/Makefile.am b/meta/Makefile.am index 184c0d920..b96483bbd 100644 --- a/meta/Makefile.am +++ b/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" diff --git a/module/ice-9/binary-ports.scm b/module/ice-9/binary-ports.scm index c07900b0d..9d6c94526 100644 --- a/module/ice-9/binary-ports.scm +++ b/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)) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 69a7fbc27..f1fd04124 100644 --- a/module/ice-9/boot-9.scm +++ b/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) - "PROC should be a procedure of one argument, and STR 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 +(define* (open-input-file + file #:key (binary #f) (encoding #f) (guess-encoding #f)) + "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 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 -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-input-file str))) +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-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) - "PROC should be a procedure of one argument, and STR should be a -string naming a file. The behaviour is unspecified if the file +(define* (call-with-output-file file proc #:key (binary #f) (encoding #f)) + "PROC should be a procedure of one argument, and FILE should be a +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 diff --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm index 0211b851c..bd1931692 100644 --- a/module/ice-9/command-line.scm +++ b/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)) diff --git a/module/ice-9/control.scm b/module/ice-9/control.scm index 5f25738fa..3eb71a483 100644 --- a/module/ice-9/control.scm +++ b/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 ...)) diff --git a/module/ice-9/futures.scm b/module/ice-9/futures.scm index 35a36ca59..90bbe53ff 100644 --- a/module/ice-9/futures.scm +++ b/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. diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 1225d92df..4476f5037 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1775,50 +1775,72 @@ 'core 'case-lambda (lambda (e r w s mod) - (let* ((tmp e) - (tmp ($sc-dispatch tmp '(_ . #(each (any any . each-any)))))) - (if tmp - (apply (lambda (args e1 e2) - (call-with-values - (lambda () - (expand-lambda-case - e - r - w - s - mod - lambda-formals - (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) - e2 - e1 - args))) - (lambda (meta lcase) (build-case-lambda s meta lcase)))) - tmp) - (syntax-violation 'case-lambda "bad case-lambda" e))))) + (letrec* + ((build-it + (lambda (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)))))) + (let* ((tmp-1 e) + (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any)))))) + (if tmp + (apply (lambda (args e1 e2) + (build-it + '() + (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) + e2 + e1 + args))) + tmp) + (let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any . each-any)))))) + (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) - (tmp ($sc-dispatch tmp '(_ . #(each (any any . each-any)))))) - (if tmp - (apply (lambda (args e1 e2) - (call-with-values - (lambda () - (expand-lambda-case - e - r - w - s - mod - lambda*-formals - (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) - e2 - e1 - args))) - (lambda (meta lcase) (build-case-lambda s meta lcase)))) - tmp) - (syntax-violation 'case-lambda "bad case-lambda*" e))))) + (letrec* + ((build-it + (lambda (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)))))) + (let* ((tmp-1 e) + (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any)))))) + (if tmp + (apply (lambda (args e1 e2) + (build-it + '() + (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) + e2 + e1 + args))) + tmp) + (let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any . each-any)))))) + (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 '())) - (if (eof-object? x) - (begin (close-input-port p) (reverse result)) - (f (read p) (cons (datum->syntax k x) result)))))))) + (let ((enc (file-encoding p))) + (set-port-encoding! p (let ((t enc)) (if t t "UTF-8"))) + (let f ((x (read p)) (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))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 1aa54020f..0176adb08 100644 --- a/module/ice-9/psyntax.scm +++ b/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 - (lambda () - (expand-lambda-case e r w s mod - lambda-formals - #'((args e1 e2 ...) ...))) - (lambda (meta lcase) - (build-case-lambda s meta lcase)))) + (build-it '() #'((args e1 e2 ...) ...))) + ((_ docstring (args e1 e2 ...) ...) + (string? (syntax->datum #'docstring)) + (build-it `((documentation + . ,(syntax->datum #'docstring))) + #'((args e1 e2 ...) ...))) (_ (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 - (lambda () - (expand-lambda-case e r w s mod - lambda*-formals - #'((args e1 e2 ...) ...))) - (lambda (meta lcase) - (build-case-lambda s meta lcase)))) + (build-it '() #'((args e1 e2 ...) ...))) + ((_ docstring (args e1 e2 ...) ...) + (string? (syntax->datum #'docstring)) + (build-it `((documentation + . ,(syntax->datum #'docstring))) + #'((args e1 e2 ...) ...))) (_ (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 - (if (absolute-file-name? fn) - fn - (in-vicinity dir fn))))) + (let* ((p (open-input-file + (if (absolute-file-name? fn) + 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) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index fe637f0a5..c5a1c4e59 100644 --- a/module/language/tree-il/peval.scm +++ b/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) diff --git a/module/srfi/srfi-41.scm b/module/srfi/srfi-41.scm index edf95d7d9..3589b359d 100644 --- a/module/srfi/srfi-41.scm +++ b/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 ...) diff --git a/module/srfi/srfi-45.scm b/module/srfi/srfi-45.scm index 51947700c..6f7ba7e04 100644 --- a/module/srfi/srfi-45.scm +++ b/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))))) diff --git a/module/sxml/match.scm b/module/sxml/match.scm index 84cbce344..2cfe64323 100644 --- a/module/sxml/match.scm +++ b/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)) diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm index 7d2b7c836..16495560c 100644 --- a/module/system/repl/repl.scm +++ b/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 - ;; to peek an EOF then read something else. It's - ;; strange but it's how it works. - ch) + (read-char)) ; consume the EOF and return it ((eqv? ch #\,) - (read-char port) + (read-char) meta-command-token) ((read-comment lang port ch) *unspecified*) diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index eb47f30bc..5c0c6a79f 100644 --- a/test-suite/standalone/Makefile.am +++ b/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 diff --git a/test-suite/standalone/test-scm-c-bind-keyword-arguments.c b/test-suite/standalone/test-scm-c-bind-keyword-arguments.c new file mode 100644 index 000000000..6fcf82180 --- /dev/null +++ b/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; +} diff --git a/test-suite/test-suite/lib.scm b/test-suite/test-suite/lib.scm index 7517b4ec5..e25df7891 100644 --- a/test-suite/test-suite/lib.scm +++ b/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)) diff --git a/test-suite/tests/00-socket.test b/test-suite/tests/00-socket.test index 7b13c5f8c..30a02570c 100644 --- a/test-suite/tests/00-socket.test +++ b/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" diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test index d88a1cb8c..0b3d57ca2 100644 --- a/test-suite/tests/arrays.test +++ b/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? diff --git a/test-suite/tests/coding.test b/test-suite/tests/coding.test index 4152af86a..a8a415ff4 100644 --- a/test-suite/tests/coding.test +++ b/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" - (equal? (scan-coding "#! coding: iso-8859-1 !#") - "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 "first line, no whitespace, no nl" - (equal? (scan-coding ";coding:iso-8859-1") - "ISO-8859-1")) - - (pass-if "first line, whitespace, no nl" - (equal? (scan-coding "; coding: iso-8859-1 ") - "ISO-8859-1")) - - (pass-if "first line, no whitespace, nl" - (equal? (scan-coding ";coding:iso-8859-1\n") - "ISO-8859-1")) - - (pass-if "first line, whitespace, nl" - (equal? (scan-coding "; coding: iso-8859-1 \n") - "ISO-8859-1")) - - (pass-if "second line, no whitespace, no nl" - (equal? (scan-coding "\n;coding:iso-8859-1") - "ISO-8859-1")) - - (pass-if "second line, whitespace, no nl" - (equal? (scan-coding "\n; coding: iso-8859-1 ") - "ISO-8859-1")) - - (pass-if "second line, no whitespace, nl" - (equal? (scan-coding "\n;coding:iso-8859-1\n") - "ISO-8859-1")) - - (pass-if "second line, whitespace, nl" - (equal? (scan-coding "\n; coding: iso-8859-1 \n") - "ISO-8859-1"))) + (pass-if-equal "first line" + "ISO-8859-1" + (scan-coding "#! coding: iso-8859-1 !#")) + + (pass-if-equal "first line no whitespace" + "ISO-8859-1" + (scan-coding "#!coding:iso-8859-1!#")) + + (pass-if-equal "second line" + "ISO-8859-1" + (scan-coding "#! \n coding: iso-8859-1 !#")) + + (pass-if-equal "second line no whitespace" + "ISO-8859-1" + (scan-coding "#!\ncoding:iso-8859-1!#")) + + (pass-if-equal "third line" + "ISO-8859-1" + (scan-coding "#! \n coding: iso-8859-1 \n !#")) + + (pass-if-equal "third line no whitespace" + "ISO-8859-1" + (scan-coding "#!\ncoding:iso-8859-1\n!#"))) + +(with-test-prefix "line comment" + (pass-if-equal "first line, no whitespace, no nl" + "ISO-8859-1" + (scan-coding ";coding:iso-8859-1")) + + (pass-if-equal "first line, whitespace, no nl" + "ISO-8859-1" + (scan-coding "; coding: iso-8859-1 ")) + + (pass-if-equal "first line, no whitespace, nl" + "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"))) diff --git a/test-suite/tests/control.test b/test-suite/tests/control.test index 1c30b9c07..5b292c4df 100644 --- a/test-suite/tests/control.test +++ b/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" diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test index 21b893796..049c9a2b0 100644 --- a/test-suite/tests/filesys.test +++ b/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"))) - (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 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" - (let ((file (search-path %load-path "ice-9/boot-9.scm"))) - (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 + (let* ((file (search-path %load-path "ice-9/boot-9.scm")) + (len (stat:size (stat file))) + (ref (call-with-input-file file get-bytevector-all))) + + (pass-if-equal "file" (cons len ref) + (let* ((result (call-with-input-file file + (lambda (input) + (call-with-output-file (test-file) + (lambda (output) + (sendfile output input len 0)))))) + (out (call-with-input-file (test-file) get-bytevector-all))) + (cons result out))) + + (pass-if-equal "file with offset" + (cons (- len 777) (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 + (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) - (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 + (seek input 777 SEEK_SET) + (get-bytevector-all input)))) + (let* ((result (call-with-input-file file (lambda (input) - (seek input 777 SEEK_SET) - (get-bytevector-all input)))) - (out (get-bytevector-all (car in+out)))) - (close-port (car in+out)) - (bytevector=? ref out))) - (throw 'unresolved)))) + (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)) diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test index 204fde7c9..9d615ce16 100644 --- a/test-suite/tests/foreign.test +++ b/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))))) diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 7d30392c8..eca4536a9 100644 --- a/test-suite/tests/numbers.test +++ b/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 diff --git a/test-suite/tests/optargs.test b/test-suite/tests/optargs.test index 0be1a541e..16a45336a 100644 --- a/test-suite/tests/optargs.test +++ b/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) diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index 886ab2418..65c87da10 100644 --- a/test-suite/tests/ports.test +++ b/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 -(pass-if "file: open-file honors coding declarations" +;; open-file ignores file coding declaration by default +(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 @@ -1110,6 +1397,90 @@ (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. (with-test-prefix "closing current-input-port" @@ -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)) diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index 3e36cca57..4b756cce8 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/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) diff --git a/test-suite/tests/ramap.test b/test-suite/tests/ramap.test index 5b99f72c9..7c3142dbd 100644 --- a/test-suite/tests/ramap.test +++ b/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))))) - - (pass-if "noncompact arrays 2" + l)) + + (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))))) - - (pass-if "noncompact arrays 3" + l)) + + (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))))) - - (pass-if "noncompact arrays 4" + l)) + + (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)))) |