[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-438-gf6f4feb
|
From: |
Mark H Weaver |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-438-gf6f4feb |
|
Date: |
Sun, 14 Apr 2013 06:49:33 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=f6f4feb0a2222efcb297e634603621126542e63f
The branch, master has been updated
via f6f4feb0a2222efcb297e634603621126542e63f (commit)
via f5b2eea6a39507ecf6a8ecc62cc1c796c45c2d1d (commit)
via 3f315b64332a61535846dc87284e091bada747e5 (commit)
via f480a98e9ac784e24e418ff307b67c22568a682e (commit)
via dac5e6491b215f8d70bc8328639b4c72cb7cd565 (commit)
via 7f74dcb4a5439bb2247875f458b5f0a20710af07 (commit)
via 800c094382c2e506c46c6e98e7b867d3df2e066f (commit)
via 039300a1ebee116082d50d61e6b3aeafc8a741ec (commit)
via cfeb9130bb5d1b512279bbdce0e9211f85d359f6 (commit)
via 3e78acd978a437c0aa5f5405daca59f1fb648516 (commit)
via fff92ff309075ed599a07a2e9378a0ed587ce073 (commit)
via 486a456d4d456f712ca9bb7b63cd58aadbaef536 (commit)
via 47ad34fad6d79c93e1d1a213641c747ba05a3ef6 (commit)
via 9a5b6f6edaf33282c29add729a9d55527abd5517 (commit)
via 11f80955e8a218ba0bfddc206b79a6916705eae8 (commit)
via 4e7d48a04bb9500afff4d44e9bc9e03c536f12f8 (commit)
via 14f2e4706863b4dafc55c7b7ff8682634f77a96e (commit)
via 40e2a31d8710eddbf564fa11d14a6af57e504448 (commit)
via 32cec09d136060e02dfa28d65f2cb19028706652 (commit)
via e67cea4214959663ff103b19cea0db9d6c869a9e (commit)
via b1b1cbcb78a7b4e2777ab596ae24d10d28aef8fb (commit)
via 82352e01ff33dfe4d554f1f8d3ec55940ed2bc43 (commit)
via f841b26d847edf2d8196c3c21c090f50cf3a614f (commit)
via 51607806ec2f2fbe4e4739c3ed599a36121e5d42 (commit)
via 3c8f2ae958f96f16ffcbb74e0b022bd9999ecb03 (commit)
via 22c76fd82288fee2cb0bb744c2e28d1be42204de (commit)
via 7ca88a403f1a81e7ab48f2b5a6d5d07ed4b5ef9b (commit)
via 7520a9b95d2661cf40f6c1bf8be79f38ca632516 (commit)
via 7f3be1db9949b0566d3a2cb6bd9d0e84287bbb0a (commit)
via eed0d26cc0668a309b610113554be5df8dfb32e9 (commit)
via e0886e0780fc1f3ce1c80d0692c11adf3b68f682 (commit)
via 254d313a21f06739930032062678ff5360d248fd (commit)
via 7099eec4fb93d74beace4cef20a93c1e4f0aee5f (commit)
via 3ace9a8e4e1de7082ceec4aea0813a6adaa913bf (commit)
via b6e374e535597448cb09588300d76b5d270d5d3a (commit)
via 3ed8d953f8d0da8ed82fe939ce48a563d7abe19b (commit)
via 7f6c3f8f0012e916469fa6c50b44c621ebdc89ac (commit)
via e1966d0e214b0967c19da71b235196adb057d2b5 (commit)
via 9a334eb3ab6bbb250d9c0f559b82d1c97f5eb21a (commit)
via bc3901092dc777d832862862e606ae2ddeb6f2f8 (commit)
via 7d39b48875475b2d206789cb9b6486b79c7be55d (commit)
via 48ffc52cc96fc0665183d9a9e3f68e7e031487f4 (commit)
via a71e79c3e5a5c366bb9ec218ee537441b8e5949a (commit)
via 3e5a164ac3d93a1a43c0e81842d0583fe0031b84 (commit)
via a16d4e82e949954805bf2cd42cfbb519fcf4012d (commit)
via c608e1aafae347dc52cda70aa9379e9b6803b5e6 (commit)
via 9c90a81bb5beafdf4e15847a59a967c70f00c400 (commit)
via 4ad329cbcaeef603d047df5dd226fb17f0b81483 (commit)
via 47ed3ca43aa32acf1550c0ff9696b1b51f43e236 (commit)
via 004094d378182d8343398c0bec817114c06ea933 (commit)
via 66750b78c7f67e91d1e01a4926e2e85a12f2b16a (commit)
via 3f1362adb5203b95079200520357bff36c3a6672 (commit)
via a24cda1d26e09ddddb2cfe6633d7fee7a1b66d35 (commit)
via d09b201d59f55f692323f82866512cba2cb29c76 (commit)
via ab1ca17986ee758b7ec4088bf3f6a596872b1677 (commit)
via b5159a471a1acbe1ad08ee5365d123912fcc607d (commit)
via 55e26a49dbc5fa7ccbf218305d88b0b37db4db3f (commit)
via d888b531681c8528a2daafe0bea70c0a42313da6 (commit)
via 96965a6ecb04b5380fd6d618e70d64dec3ac37be (commit)
via e501f2111e0d5a8bc037cfe3df4e6ba0655285d5 (commit)
via 4b76acfa38d6939241e0b4cfdbbc46e8aac13e1a (commit)
via 4a1cdc9d5d643d05fa7a18febc7c12070f3ef6d9 (commit)
via cdd3d6c9f423d5b95f05193fe3c27d50b56957e9 (commit)
via 45c0878b8665182f06a917e391169031c1dc7db6 (commit)
via 0426b3f8f8036364aca13c24ef769283937faa3d (commit)
via 71539c1cd3bf16dfdb87dc6c0c5f4238ebf8dcd9 (commit)
via 412053922501e2e9cac7fc0c1b91de8fc3aa375a (commit)
via c3e3ef6eb6d1487d342389b202b0b00f9385de6a (commit)
via 3220b080498580586726313ec63db9eaf68334d8 (commit)
via 0d7f3a6d957a3129dc0aa203abc1b6adc82db295 (commit)
via 51a1763f6596d594ebd774e7c3fd9138e6f4d507 (commit)
via 9a68d7b388c610cdbc5689ae9cbadb70ee311f67 (commit)
via 75a1b26c5d06e791afce10be9b1ab4e5272e45b4 (commit)
via 7290de89fb5bf755e2520bd01e977dc132c50c4b (commit)
via 72e2b5923a15f49fd7f7706fe35dfc1157a41bb5 (commit)
via 9a31a54561b859dfbaca4f4523252a76adb56386 (commit)
via e00793d7a986053976c088f4aa4088c4d648825d (commit)
via 1fa89aaf6191dfe24e7494726ce37b698736103f (commit)
via 1ee237d9a159e0e9a995ecb9fea24e1d39a7c5e1 (commit)
via 8a2b596579185cd0f4d35da478f447e529d81a80 (commit)
via 187fa0b9e7ff9b2d6204517a9daa9009245c7511 (commit)
via 05d7f76296dc9fa21e0abd1ce6105a042905f48e (commit)
via 21bbe22a14a75fab54a5a8563fad63851a18fee3 (commit)
via 337edc591ffd8f8ec4176b0112ad10da29818141 (commit)
via e459855936262b4bddaebd87a75abdc065799be2 (commit)
via 663780bb1c881947b6e4f00c456b2b367701982d (commit)
via 369294866dd7ee01ebf821df2a119ea55b1e68fd (commit)
from 1e051065628a7f1bd4398fcc11cd181f86084629 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit f6f4feb0a2222efcb297e634603621126542e63f
Merge: 1e05106 f5b2eea
Author: Mark H Weaver <address@hidden>
Date: Sun Apr 14 02:48:33 2013 -0400
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
-----------------------------------------------------------------------
Summary of changes:
NEWS | 257 +++++---
README | 2 +-
THANKS | 14 +
configure.ac | 33 +-
doc/guile-api.alist | 1 -
doc/ref/api-binding.texi | 4 +-
doc/ref/api-compound.texi | 8 +-
doc/ref/api-control.texi | 56 ++-
doc/ref/api-data.texi | 96 +++-
doc/ref/api-evaluation.texi | 36 +-
doc/ref/api-io.texi | 192 +++++-
doc/ref/api-modules.texi | 122 +----
doc/ref/api-procedures.texi | 4 +-
doc/ref/guile-invoke.texi | 29 +
doc/ref/posix.texi | 48 ++-
doc/ref/r6rs.texi | 4 +-
doc/release.org | 17 +-
lib/Makefile.am | 2 +-
libguile/Makefile.am | 5 +-
libguile/array-map.c | 196 ++++---
libguile/array-map.h | 29 +-
libguile/filesys.c | 61 ++-
libguile/fports.c | 212 ++++---
libguile/fports.h | 3 +
libguile/gc.h | 3 +-
libguile/gen-scmconfig.c | 2 +-
libguile/init.c | 1 +
libguile/keywords.c | 67 ++
libguile/keywords.h | 12 +
libguile/ports-internal.h | 66 ++
libguile/ports.c | 548 ++++++++++++-----
libguile/ports.h | 80 +--
libguile/print.c | 29 +-
libguile/r6rs-ports.c | 122 ++--
libguile/read.c | 42 +-
libguile/stime.c | 22 +-
libguile/strings.c | 20 +-
libguile/vports.c | 8 +-
m4/gnulib-cache.m4 | 3 +-
meta/Makefile.am | 4 +-
module/ice-9/binary-ports.scm | 3 +-
module/ice-9/boot-9.scm | 82 ++-
module/ice-9/command-line.scm | 2 +-
module/ice-9/control.scm | 32 +-
module/ice-9/futures.scm | 11 +-
module/ice-9/psyntax-pp.scm | 112 ++--
module/ice-9/psyntax.scm | 55 ++-
module/language/tree-il/peval.scm | 10 +-
module/srfi/srfi-41.scm | 25 +-
module/srfi/srfi-45.scm | 17 +-
module/sxml/match.scm | 19 +-
module/system/repl/repl.scm | 7 +-
test-suite/standalone/Makefile.am | 7 +
.../standalone/test-scm-c-bind-keyword-arguments.c | 201 ++++++
test-suite/test-suite/lib.scm | 9 +-
test-suite/tests/00-socket.test | 11 +-
test-suite/tests/arrays.test | 50 ++-
test-suite/tests/coding.test | 116 ++--
test-suite/tests/control.test | 30 +-
test-suite/tests/filesys.test | 148 +++--
test-suite/tests/foreign.test | 10 +-
test-suite/tests/numbers.test | 3 +-
test-suite/tests/optargs.test | 18 +-
test-suite/tests/ports.test | 661 +++++++++++++++++++-
test-suite/tests/r6rs-ports.test | 24 -
test-suite/tests/ramap.test | 58 ++-
66 files changed, 3076 insertions(+), 1105 deletions(-)
mode change 100644 => 100755 build-aux/gendocs.sh
create mode 100644 libguile/ports-internal.h
create mode 100644 test-suite/standalone/test-scm-c-bind-keyword-arguments.c
diff --git a/NEWS b/NEWS
index 92dc19f..5913301 100644
--- a/NEWS
+++ b/NEWS
@@ -5,23 +5,28 @@ See the end for copying conditions.
Please send Guile bug reports to address@hidden
-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)
diff --git a/README b/README
index 480ef66..215f9e5 100644
--- a/README
+++ b/README
@@ -72,7 +72,7 @@ Guile requires the following external packages:
libltdl is used for loading extensions at run-time. It is
available from http://www.gnu.org/software/libtool/ .
- - GNU libunistring
+ - GNU libunistring, at least version 0.9.3
libunistring is used for Unicode string operations, such as the
`utf*->string' procedures. It is available from
diff --git a/THANKS b/THANKS
index 8209996..a01dcfb 100644
--- a/THANKS
+++ b/THANKS
@@ -1,7 +1,9 @@
Contributors since the last release:
+ Greg Benison
Tristan Colgate-McFarlane
Ludovic Courtès
+ Jason Earl
Brian Gough
Volker Grabsch
Julian Graham
@@ -10,8 +12,11 @@ Contributors since the last release:
No Itisnt
Neil Jerram
Chris K Jester-Young
+ David Kastrup
Daniel Kraft
+ Daniel Krueger
Noah Lavine
+ Daniel Llorens
Gregory Marton
Thien-Thi Nguyen
Han-Wen Nienhuys
@@ -22,11 +27,14 @@ Contributors since the last release:
Ken Raeburn
Andreas Rottmann
Kevin Ryde
+ Stefan I Tampe
BT Templeton
+ Bake Timmons
Mark H Weaver
Göran Weinholt
Ralf Wildenhues
Andy Wingo
+ Eli Zaretskii
Authors of free software libraries that have been included into Guile
since the last release:
@@ -42,6 +50,7 @@ For fixes or providing information which led to a fix:
Hans Ã
berg
David Allouche
Andrew Bagdanov
+ LluÃs Batlle i Rossell
Martin Baulig
Fabrice Bauzac
Sylvain Beucler
@@ -95,6 +104,7 @@ For fixes or providing information which led to a fix:
David Jaquay
Paul Jarc
Steve Juranich
+ Nikita Karetnikov
David Kastrup
Richard Kim
Bruce Korb
@@ -138,17 +148,20 @@ For fixes or providing information which led to a fix:
Hugh Sasse
Werner Scheinast
Bill Schottstaedt
+ Jan Schukat
Frank Schwidom
John Steele Scott
Thiemo Seufer
Ivan Shcherbakov
Scott Shedden
Alex Shinn
+ Peter Simons
Daniel Skarda
Dale Smith
Cesar Strauss
Klaus Stehle
Rainer Tammer
+ Samuel Thibault
Richard Todd
Issac Trotts
Greg Troxel
@@ -166,6 +179,7 @@ For fixes or providing information which led to a fix:
Thomas Wawrzinek
Mark H. Weaver
Göran Weinholt
+ David A. Wheeler
Ralf Wildenhues
Jon Wilson
Andy Wingo
diff --git a/build-aux/gendocs.sh b/build-aux/gendocs.sh
old mode 100644
new mode 100755
diff --git a/configure.ac b/configure.ac
index 60aa49f..3cbd960 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 5830c91..78d3a5c 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 5763f36..e3a9918 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))
address@hidden ;; 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 641245a..699e760 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.
address@hidden
address@hidden 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 4dede72..f34074e 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.
address@hidden 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.
+
address@hidden {Scheme Procedure} call-with-escape-continuation proc
address@hidden {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}.
+
address@hidden
+(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))
address@hidden (0 1 2)
address@hidden lisp
address@hidden deffn
+
address@hidden {Scheme Syntax} let-escape-continuation k body @dots{}
address@hidden {Scheme Syntax} let/ec k body @dots{}
+Bind @var{k} within @var{body} to an escape continuation.
+
+This is equivalent to
address@hidden(call/ec (lambda (@var{k}) @var{body} @dots{}))}.
address@hidden 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
address@hidden 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 e3c94e2..7603180 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
address@hidden string->bytevector string encoding [conversion-strategy]
address@hidden {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
address@hidden bytevector->string bytevector encoding [conversion-strategy]
address@hidden {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
address@hidden call-with-output-encoded-string encoding proc
[conversion-strategy]
address@hidden {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
address@hidden, @code{scm_from_utf8_string} or
address@hidden
+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.
address@hidden {C Function} scm_from_latin1_symbol (const char *name)
address@hidden {C Function} scm_from_utf8_symbol (const char *name)
address@hidden {C Function} SCM scm_from_latin1_symbol (const char *name)
address@hidden {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
address@hidden {C Function} scm_from_locale_symbol (const char *name)
address@hidden {C Function} scm_from_locale_symboln (const char *name, size_t
len)
address@hidden {C Function} SCM scm_from_locale_symbol (const char *name)
address@hidden {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
address@hidden 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
address@hidden 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
address@hidden {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
address@hidden 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
address@hidden and @var{argpN}. The argument list to
address@hidden must be terminated by
address@hidden
+
+Note that since the variables pointed to by @var{argp1} through
address@hidden 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
address@hidden after the call to see which ones were provided.
+
+If an unrecognized keyword argument is present in @var{rest} and
address@hidden does not contain @code{SCM_ALLOW_OTHER_KEYS}, or if
+non-keyword arguments are present and @var{flags} does not contain
address@hidden, an exception is raised.
address@hidden should be the name of the procedure receiving the keyword
+arguments, for purposes of error reporting.
+
+For example:
+
address@hidden
+SCM k_delimiter;
+SCM k_grammar;
+SCM sym_infix;
+
+SCM my_string_join (SCM strings, SCM rest)
address@hidden
+ 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);
address@hidden
+
+void my_init ()
address@hidden
+ 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);
address@hidden
address@hidden example
address@hidden deftypefn
+
+
@node Other Types
@subsection ``Functionality-Centric'' Data Types
diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi
index 7afbcfa..63b1d60 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
address@hidden 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
address@hidden: 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 11ae580..4c42de8 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,
address@hidden 2010, 2011 Free Software Foundation, Inc.
address@hidden 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}).
address@hidden {Scheme Procedure} open-file filename mode
address@hidden {Scheme Procedure} open-file filename mode @
+ [#:guess-encoding=#f] [#:encoding=#f]
address@hidden {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.
address@hidden, 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
address@hidden 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.
address@hidden, 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
address@hidden, unless the @code{b} flag was supplied.
+Sometimes it is desirable to honor Emacs-style coding declarations in
address@hidden 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,
address@hidden):
-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
address@hidden
address@hidden
+(let* ((port (open-input-file file))
+ (encoding (file-encoding port)))
+ (set-port-encoding! port (or encoding (port-encoding port))))
address@hidden 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
address@hidden {Scheme Procedure} open-input-file filename
-Open @var{filename} for input. Equivalent to
address@hidden {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
address@hidden 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
address@hidden {Scheme Procedure} open-output-file filename
-Open @var{filename} for output. Equivalent to
address@hidden {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
address@hidden {Scheme Procedure} call-with-input-file filename proc
address@hidden {Scheme Procedure} call-with-output-file filename proc
address@hidden {Scheme Procedure} call-with-input-file filename proc @
+ [#:guess-encoding=#f] [#:encoding=#f] [#:binary=#f]
address@hidden {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
address@hidden {Scheme Procedure} with-input-from-file filename thunk
address@hidden {Scheme Procedure} with-output-to-file filename thunk
address@hidden {Scheme Procedure} with-error-to-file filename thunk
address@hidden {Scheme Procedure} with-input-from-file filename thunk @
+ [#:guess-encoding=#f] [#:encoding=#f] [#:binary=#f]
address@hidden {Scheme Procedure} with-output-to-file filename thunk @
+ [#:encoding=#f] [#:binary=#f]
address@hidden {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
address@hidden(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)}:
+
address@hidden {Scheme Procedure} unget-bytevector port bv [start [count]]
address@hidden {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.
address@hidden deffn
+
@node R6RS Textual Input
@subsubsection Textual Input
@@ -2372,6 +2428,84 @@ Set using
@end table
address@hidden BOM Handling
address@hidden Handling of Unicode byte order marks.
address@hidden BOM
address@hidden 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
address@hidden, @code{UTF-16} or @code{UTF-32}. If the port encoding is
+set to @code{UTF-16BE}, @code{UTF-16LE}, @code{UTF-32BE}, or
address@hidden, then BOMs are @emph{not} handled specially, and none of
+the special handling described in this section applies.
+
address@hidden @bullet
address@hidden
+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.
+
address@hidden
+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
address@hidden, @code{UTF-16LE}, @code{UTF-32BE}, or @code{UTF-32LE},
+and explicitly write a BOM (@code{#\xFEFF}) if desired.
+
address@hidden
+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.
+
address@hidden
+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.
+
address@hidden
+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
address@hidden consume a BOM.
+
address@hidden
+For ports that do not support seeking (e.g. pipes, sockets, and
+terminals), the input and output streams are considered
address@hidden 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.
+
address@hidden
+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.
address@hidden 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 4a4011d..286a37d 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},
address@hidden, @code{open-input-pipe}, and so on (@pxref{Included
-Guile Modules}).
address@hidden, @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
address@hidden Included Guile Modules
address@hidden 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:
-
address@hidden @strong
address@hidden boot-9
-boot-9 is Guile's initialization module, and it is always loaded when
-Guile starts up.
-
address@hidden (ice-9 expect)
-Actions based on matching input from a port (@pxref{Expect}).
-
address@hidden (ice-9 format)
-Formatted output in the style of Common Lisp (@pxref{Formatted
-Output}).
-
address@hidden (ice-9 ftw)
-File tree walker (@pxref{File Tree Walk}).
-
address@hidden (ice-9 getopt-long)
-Command line option processing (@pxref{getopt-long}).
-
address@hidden (ice-9 history)
-Refer to previous interactive expressions (@pxref{Value History}).
-
address@hidden (ice-9 popen)
-Pipes to and from child processes (@pxref{Pipes}).
-
address@hidden (ice-9 pretty-print)
-Nicely formatted output of Scheme expressions and objects
-(@pxref{Pretty Printing}).
-
address@hidden (ice-9 q)
-First-in first-out queues (@pxref{Queues}).
-
address@hidden (ice-9 rdelim)
-Line- and character-delimited input (@pxref{Line/Delimited}).
-
address@hidden (ice-9 readline)
address@hidden interactive command line editing (@pxref{Readline
-Support}).
-
address@hidden (ice-9 receive)
-Multiple-value handling with @code{receive} (@pxref{Multiple Values}).
-
address@hidden (ice-9 regex)
-Regular expression matching (@pxref{Regular Expressions}).
-
address@hidden (ice-9 rw)
-Block string input/output (@pxref{Block Reading and Writing}).
-
address@hidden (ice-9 streams)
-Sequence of values calculated on-demand (@pxref{Streams}).
-
address@hidden (ice-9 syncase)
-R5RS @code{syntax-rules} macro system (@pxref{Syntax Rules}).
-
address@hidden (ice-9 threads)
-Guile's support for multi threaded execution (@pxref{Scheduling}).
-
address@hidden (ice-9 documentation)
-Online documentation (REFFIXME).
-
address@hidden (srfi srfi-1)
-A library providing a lot of useful list and pair processing
-procedures (@pxref{SRFI-1}).
-
address@hidden (srfi srfi-2)
-Support for @code{and-let*} (@pxref{SRFI-2}).
-
address@hidden (srfi srfi-4)
-Support for homogeneous numeric vectors (@pxref{SRFI-4}).
-
address@hidden (srfi srfi-6)
-Support for some additional string port procedures (@pxref{SRFI-6}).
-
address@hidden (srfi srfi-8)
-Multiple-value handling with @code{receive} (@pxref{SRFI-8}).
-
address@hidden (srfi srfi-9)
-Record definition with @code{define-record-type} (@pxref{SRFI-9}).
-
address@hidden (srfi srfi-10)
-Read hash extension @code{#,()} (@pxref{SRFI-10}).
-
address@hidden (srfi srfi-11)
-Multiple-value handling with @code{let-values} and @code{let*-values}
-(@pxref{SRFI-11}).
-
address@hidden (srfi srfi-13)
-String library (@pxref{SRFI-13}).
-
address@hidden (srfi srfi-14)
-Character-set library (@pxref{SRFI-14}).
-
address@hidden (srfi srfi-16)
address@hidden procedures of variable arity (@pxref{SRFI-16}).
-
address@hidden (srfi srfi-17)
-Getter-with-setter support (@pxref{SRFI-17}).
-
address@hidden (srfi srfi-19)
-Time/Date library (@pxref{SRFI-19}).
-
address@hidden (srfi srfi-26)
-Convenient syntax for partial application (@pxref{SRFI-26})
-
address@hidden (srfi srfi-31)
address@hidden convenient recursive expressions (@pxref{SRFI-31})
-
address@hidden (ice-9 slib)
-This module contains hooks for using Aubrey Jaffer's portable Scheme
-library SLIB from Guile (@pxref{SLIB}).
address@hidden table
-
-
@node provide and require
@subsection provide and require
diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi
index 8ff240a..e11479d 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 90922f2..207c6f3 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.
address@hidden
+
address@hidden address@hidden
+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
address@hidden (for Emacs Lisp), and @code{ecmascript}.
+
+The example below shows the evaluation of expressions in Scheme, Emacs
+Lisp, and ECMAScript:
+
address@hidden
+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);'
address@hidden example
+
+To load a file written in Scheme and one written in Emacs Lisp, and then
+start a Scheme REPL, type:
+
address@hidden
+guile -l foo.scm --language=elisp -l foo.el --language=scheme
address@hidden example
+
@vnew{2.0}
@item address@hidden, }--help
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index e203090..40c20e7 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
address@hidden 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
address@hidden file name separator
address@hidden 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
address@hidden/} 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
address@hidden:\} for absolute file names. The following procedures and
+variables provide support for portable file name manipulations.
+
address@hidden {Scheme Procedure} system-file-name-convention
+Return either @code{posix} or @code{windows}, depending on
+what kind of system this Guile is running on.
address@hidden deffn
+
address@hidden {Scheme Procedure} file-name-separator? c
+Return true if character @var{c} is a file name separator on the host
+platform.
address@hidden deffn
+
address@hidden {Scheme Procedure} absolute-file-name? file-name
+Return true if @var{file-name} denotes an absolute file name on the host
+platform.
address@hidden deffn
+
address@hidden {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
address@hidden is the @emph{only} file name
+separator---e.g., when extracting the components of a file name.
address@hidden defvr
+
@node User Information
@subsection User Information
diff --git a/doc/ref/r6rs.texi b/doc/ref/r6rs.texi
index b183771..9c5984b 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;
address@hidden, and @ref{SRFI-9}, for a description of those
address@hidden, 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 95ba12e..875ec27 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: address@hidden
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 address@hidden'
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 fdcd45d..8857a90 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 6f914e0..6c9d795 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 c0f0f00..e47fb56 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 43d2a92..b0592d8 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 09a0de0..1893c02 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 067c3e2..13d1dd7 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"
- "address@hidden 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 4094f14..092b43e 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 b1df82d..0857781 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 d8dea7f..11020cf 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 fb952f2..6787483 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 e4a79ac..96c0b01 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 c9e6af1..3cdb0ec 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 0000000..bff89cb
--- /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 31d338e..20c9081 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 c1ba719..80644898 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 5d5c56d..6524091 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 7d07051..c6ad90a 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 7c003b4..c8db812 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 90de697..78539d9 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 23a1a70..fa97a00 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 a886e36..e726330 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 d6dd66d..81e4646 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 184c0d9..b96483b 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 c07900b..9d6c945 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 69a7fbc..f1fd041 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 0211b85..bd19316 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 5f25738..3eb71a4 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 35a36ca..90bbe53 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 <address@hidden>
@@ -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 1225d92..4476f50 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 1aa5402..0176adb 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 fe637f0..c5a1c4e 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 edf95d7..3589b35 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 5194770..6f7ba7e 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 84cbce3..2cfe643 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 7d2b7c8..1649556 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 eb47f30..5c0c6a7 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 0000000..6fcf821
--- /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 7517b4e..e25df78 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 7b13c5f..30a0257 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 d88a1cb..0b3d57c 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 4152af8..a8a415f 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 1c30b9c..5b292c4 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 21b8937..049c9a2 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 204fde7..9d615ce 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 7d30392..eca4536 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 0be1a54..16a4533 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 886ab24..65c87da 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 3e36cca..4b756cc 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 5b99f72..7c3142d 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))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-438-gf6f4feb,
Mark H Weaver <=