[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-433-gfa980bc
|
From: |
Mark H Weaver |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-433-gfa980bc |
|
Date: |
Wed, 31 Oct 2012 03:47:32 +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=fa980bcc0f5b186b98d84fc5d165d35fcbb5d5ec
The branch, master has been updated
via fa980bcc0f5b186b98d84fc5d165d35fcbb5d5ec (commit)
via 10744b7c5007ccac19ea9654be6e749fe6a60992 (commit)
via fa746547fc0cd15f5edbb690477d37a23de4f183 (commit)
via fb210d8d165ea234a72f0f4dd25239ad21f64991 (commit)
via 8d5000586849d2997ffd7f88e78cab1e9aebcbbf (commit)
via bf9eb54aab23ebe01779ad0bbaab624e6ceb47b2 (commit)
via 9331ffd891d03bc736f98bf92628b4b2fa714e68 (commit)
via ea8c97615590ec60f2df0f7f356b04aa0a174eef (commit)
via 851c3cd16e6b9caee069581aa34e198d1df14c71 (commit)
via 02327c0c5159809e204a561c2e12b84cbb8f0c20 (commit)
via 3655ed89834b9896fe267107c50cc4af8e0b5ecf (commit)
via b1b5433d66ccc8267a70c6ca3c0a630bddea4edb (commit)
via 603234c611b50cdc8770b2a822cd333812eed98d (commit)
via 493ceb99e520a307c51fbee3633d89f688e2d3f7 (commit)
via ead2496f73d401b096bb92e66e7434160d65c6e2 (commit)
via 591065954c340553214d49512cfb539177b58dcf (commit)
via b3a2259ce3ffeb6a33093f5d02fa04aba15c633a (commit)
via 495797ceb50a857a033f390b4fc35e2989bd66cd (commit)
via f865ffaab159e52d48b015bea7280b2940753482 (commit)
via d74fcce9b98135042fd713180c587dff0239d6b3 (commit)
via 2663411bd7d7d6b7be6c674c4e6c35c22e2e3c19 (commit)
via 8ac870dee4397c3b3f0ac24b072e88e87b91e47e (commit)
via 6996f07f577416505b2e33e5967f9fcc933559b7 (commit)
via 5f085775aba737c6e829b3e06abb66a64c83b057 (commit)
via 8b22ced1c9dee2743eedb5658172e931a42e8453 (commit)
via 3e3d32dd9b2d71ffb0703dedc4d47387e981c9b5 (commit)
via 75a5de18a0e6e34963cf0f5e0e20f528222e06af (commit)
via bcf87e35e17741c279b755b0804776cdc8ee5828 (commit)
via ebd363161ef533833fc48c3389075bf4db7ebe17 (commit)
via 2446f8e126d9a7c145c4868f2a918d2dfb226d4e (commit)
via 226a56a3d454b18b2b57c4489fdb8efbf4cd8332 (commit)
via 88644a10d82045f429f66f20a47973e48715de1d (commit)
via d6e1c8bfdb727f39352c7304c225c05545067f30 (commit)
via b6aedd68bcbb07c9c6fd60e10cde314b68b0e1e9 (commit)
via e7350baf1e93d68eb7dc23fc16f711c066cb37ec (commit)
via 985538837806ab8dadfe3c01388355b9f551a303 (commit)
via 4aaceda29fc70124e64397c1593dc07a3a73a463 (commit)
via 068adc1980535f187ad9721d67f223c52546c38a (commit)
via 8a84f7fb46182c9220da514bc25d85ee799c799f (commit)
via a8872c78a4baa6c98e60924919d9adb7e651a7df (commit)
via d6bd18261895a9b7cb9570c95b779c615e261728 (commit)
via 7aa394b53c289c1f05dacaef8a9167fbaecc00fa (commit)
via fd99e505d794049bb1a06aa1e9de8a0f9cff6689 (commit)
via 866210bf247ea57bed5421ce8887a84e53347acb (commit)
via b401fe71692a4473a51c39d7964ce554bf2ced37 (commit)
via dc7a9cefbf5434b6e7e503fe83faa07b24a1a6cd (commit)
via 6c9220064d987deee813cfd933d50353d14d4c0f (commit)
via b908768a7ec79f78def344c464186a51f55b69e8 (commit)
via ee26a9ebe2d93263473db7d68e74a317eaf053ac (commit)
via 639fd0a44265ba9223793eea9b5ae4d3c4da5237 (commit)
via 93723f3d1d4ed211a7a0d1ec547dfeb005424490 (commit)
via ecbded71bb423a6055c541d6272796aefd1486f9 (commit)
via cc26b9de1d3c21cb4be49cc61c4b5872b8f607c5 (commit)
from e088b09d7dce5d78c96288778969876b6d25d726 (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 fa980bcc0f5b186b98d84fc5d165d35fcbb5d5ec
Merge: e088b09 10744b7
Author: Mark H Weaver <address@hidden>
Date: Tue Oct 30 23:46:31 2012 -0400
Merge remote-tracking branch 'origin/stable-2.0'
Moved scm_i_struct_hash from struct.c to hash.c and made it static.
The port's alist is now a field of 'scm_t_port'.
Conflicts:
libguile/arrays.c
libguile/hash.c
libguile/ports.c
libguile/print.h
libguile/read.c
-----------------------------------------------------------------------
Summary of changes:
THANKS | 1 +
configure.ac | 2 +-
doc/ref/Makefile.am | 1 +
doc/ref/api-data.texi | 22 +-
doc/ref/api-evaluation.texi | 27 +-
doc/ref/api-options.texi | 1 +
doc/ref/api-regex.texi | 13 +-
doc/ref/curried.texi | 56 +++
doc/ref/guile.texi | 2 +
doc/ref/scheme-ideas.texi | 5 +
doc/ref/scheme-using.texi | 2 +-
doc/ref/srfi-modules.texi | 59 +++-
doc/ref/tour.texi | 6 +-
libguile/arrays.c | 175 +-------
libguile/arrays.h | 4 +-
libguile/hash.c | 52 ++-
libguile/list.c | 17 +-
libguile/ports.c | 4 +-
libguile/ports.h | 4 +
libguile/print.c | 23 +
libguile/print.h | 5 +-
libguile/private-options.h | 3 +-
libguile/read.c | 833 ++++++++++++++++++++++++++------
libguile/read.h | 1 -
libguile/srfi-13.c | 97 +++--
libguile/srfi-13.h | 2 +-
libguile/strings.c | 4 +
meta/Makefile.am | 2 +-
module/ice-9/boot-9.scm | 14 +-
module/ice-9/command-line.scm | 14 +-
module/ice-9/curried-definitions.scm | 14 +-
module/ice-9/format.scm | 14 +-
module/ice-9/regex.scm | 3 +-
module/language/tree-il/primitives.scm | 21 +
module/srfi/srfi-19.scm | 8 +-
module/srfi/srfi-31.scm | 26 +-
module/system/base/compile.scm | 19 +-
module/texinfo.scm | 28 +-
module/web/client.scm | 46 ++-
module/web/uri.scm | 6 +-
test-suite/Makefile.am | 1 +
test-suite/tests/chars.test | 84 ++--
test-suite/tests/list.test | 6 +-
test-suite/tests/numbers.test | 2 +-
test-suite/tests/reader.test | 13 +
test-suite/tests/regexp.test | 24 +-
test-suite/tests/srfi-105.test | 240 +++++++++
test-suite/tests/srfi-31.test | 7 +-
test-suite/tests/strings.test | 62 +++-
test-suite/tests/structs.test | 42 ++
test-suite/tests/texinfo.test | 3 +-
test-suite/tests/tree-il.test | 82 ++++
test-suite/tests/web-uri.test | 4 +-
53 files changed, 1676 insertions(+), 530 deletions(-)
create mode 100644 doc/ref/curried.texi
create mode 100644 test-suite/tests/srfi-105.test
diff --git a/THANKS b/THANKS
index a3d15de..2dbf570 100644
--- a/THANKS
+++ b/THANKS
@@ -6,6 +6,7 @@ Contributors since the last release:
Volker Grabsch
Julian Graham
Michael Gran
+ Daniel Hartwig
No Itisnt
Neil Jerram
Daniel Kraft
diff --git a/configure.ac b/configure.ac
index ab4e147..8adfd47 100644
--- a/configure.ac
+++ b/configure.ac
@@ -36,7 +36,7 @@ AC_CONFIG_MACRO_DIR([m4])
AC_CONFIG_SRCDIR(GUILE-VERSION)
dnl `AM_SUBST_NOTMAKE' was introduced in Automake 1.11.
-AM_INIT_AUTOMAKE([1.11 gnu no-define -Wall -Wno-override dist-xz])
+AM_INIT_AUTOMAKE([1.11 gnu no-define -Wall -Wno-override color-tests dist-xz])
m4_ifdef([AM_SILENT_RULES], [AM_SILENT_RULES([yes])],
[AC_SUBST([AM_DEFAULT_VERBOSITY],1)])
AC_COPYRIGHT(GUILE_CONFIGURE_COPYRIGHT)
diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am
index abe9cb9..201ab6b 100644
--- a/doc/ref/Makefile.am
+++ b/doc/ref/Makefile.am
@@ -62,6 +62,7 @@ guile_TEXINFOS = preface.texi \
web.texi \
expect.texi \
scsh.texi \
+ curried.texi \
sxml-match.texi \
scheme-scripts.texi \
api-overview.texi \
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 39c9790..6d8de2b 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -3152,12 +3152,24 @@ These procedures are useful for similar tasks.
Convert the string @var{str} into a list of characters.
@end deffn
address@hidden {Scheme Procedure} string-split str chr
address@hidden {C Function} scm_string_split (str, chr)
address@hidden {Scheme Procedure} string-split str char_pred
address@hidden {C Function} scm_string_split (str, char_pred)
Split the string @var{str} into a list of substrings delimited
-by appearances of the character @var{chr}. Note that an empty substring
-between separator characters will result in an empty string in the
-result list.
+by appearances of characters that
+
address@hidden @bullet
address@hidden
+equal @var{char_pred}, if it is a character,
+
address@hidden
+satisfy the predicate @var{char_pred}, if it is a procedure,
+
address@hidden
+are in the set @var{char_pred}, if it is a character set.
address@hidden itemize
+
+Note that an empty substring between separator characters will result in
+an empty string in the result list.
@lisp
(string-split "root:x:0:0:root:/root:/bin/bash" #\:)
diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi
index 6112832..c471f64 100644
--- a/doc/ref/api-evaluation.texi
+++ b/doc/ref/api-evaluation.texi
@@ -254,6 +254,8 @@ Encoding of Source Files}.
@node Case Sensitivity
@subsubsection Case Sensitivity
address@hidden fold-case
address@hidden no-fold-case
@c FIXME::martin: Review me!
@@ -275,9 +277,9 @@ options, @xref{Scheme Read}.
(read-enable 'case-insensitive)
@end lisp
-Note that this is seldom a problem, because Scheme programmers tend not
-to use uppercase letters in their identifiers anyway.
-
+It is also possible to disable (or enable) case sensitivity within a
+single file by placing the reader directives @code{#!fold-case} (or
address@hidden) within the file itself.
@node Keyword Syntax
@subsubsection Keyword Syntax
@@ -315,10 +317,10 @@ its read options.
@cindex options - read
@cindex read options
@deffn {Scheme Procedure} read-options [setting]
-Display the current settings of the read options. If @var{setting} is
-omitted, only a short form of the current read options is printed.
-Otherwise if @var{setting} is the symbol @code{help}, a complete options
-description is displayed.
+Display the current settings of the global read options. If
address@hidden is omitted, only a short form of the current read options
+is printed. Otherwise if @var{setting} is the symbol @code{help}, a
+complete options description is displayed.
@end deffn
The set of available options, and their default values, may be had by
@@ -336,8 +338,19 @@ r6rs-hex-escapes no Use R6RS variable-length character
and string hex escape
square-brackets yes Treat `[' and `]' as parentheses, for R6RS
compatibility.
hungry-eol-escapes no In strings, consume leading whitespace after an
escaped end-of-line.
+curly-infix no Support SRFI-105 curly infix expressions.
@end smalllisp
+Note that Guile also includes a preliminary mechanism for setting read
+options on a per-port basis. For instance, the @code{case-insensitive}
+read option is set (or unset) on the port when the reader encounters the
address@hidden or @code{#!no-fold-case} reader directives.
+Similarly, the @code{#!curly-infix} reader directive sets the
address@hidden read option on the port, and
address@hidden sets @code{curly-infix} and
+unsets @code{square-brackets} on the port (@pxref{SRFI-105}). There is
+currently no other way to access or set the per-port read options.
+
The boolean options may be toggled with @code{read-enable} and
@code{read-disable}. The non-boolean @code{keywords} option must be set
using @code{read-set!}.
diff --git a/doc/ref/api-options.texi b/doc/ref/api-options.texi
index f635978..1734318 100644
--- a/doc/ref/api-options.texi
+++ b/doc/ref/api-options.texi
@@ -390,6 +390,7 @@ r6rs-hex-escapes no Use R6RS variable-length character
and string hex escape
square-brackets yes Treat `[' and `]' as parentheses, for R6RS
compatibility.
hungry-eol-escapes no In strings, consume leading whitespace after an
escaped end-of-line.
+curly-infix no Support SRFI-105 curly infix expressions.
scheme@@(guile-user) [1]> (read-enable 'case-insensitive)
$2 = (square-brackets keywords #f case-insensitive positions)
scheme@@(guile-user) [1]> ,q
diff --git a/doc/ref/api-regex.texi b/doc/ref/api-regex.texi
index 11a31fc..082fb87 100644
--- a/doc/ref/api-regex.texi
+++ b/doc/ref/api-regex.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007,
2009, 2010
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007,
2009, 2010, 2012
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -54,11 +54,12 @@ Zero bytes (@code{#\nul}) cannot be used in regex patterns
or input
strings, since the underlying C functions treat that as the end of
string. If there's a zero byte an error is thrown.
-Patterns and input strings are treated as being in the locale
-character set if @code{setlocale} has been called (@pxref{Locales}),
-and in a multibyte locale this includes treating multi-byte sequences
-as a single character. (Guile strings are currently merely bytes,
-though this may change in the future, @xref{Conversion to/from C}.)
+Internally, patterns and input strings are converted to the current
+locale's encoding, and then passed to the C library's regular expression
+routines (@pxref{Regular Expressions,,, libc, The GNU C Library
+Reference Manual}). The returned match structures always point to
+characters in the strings, not to individual bytes, even in the case of
+multi-byte encodings.
@deffn {Scheme Procedure} string-match pattern str [start]
Compile the string @var{pattern} into a regular expression and compare
diff --git a/doc/ref/curried.texi b/doc/ref/curried.texi
new file mode 100644
index 0000000..25430b4
--- /dev/null
+++ b/doc/ref/curried.texi
@@ -0,0 +1,56 @@
address@hidden -*-texinfo-*-
address@hidden This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 2012 Free Software Foundation, Inc.
address@hidden See the file guile.texi for copying conditions.
+
address@hidden Curried Definitions
address@hidden Curried Definitions
+
+The macros in this section are provided by
address@hidden
+(use-modules (ice-9 curried-definitions))
address@hidden lisp
address@hidden
+and replace those provided by default.
+
+Prior to Guile 2.0, Guile provided a type of definition known colloquially
+as a ``curried definition''. The idea is to extend the syntax of
address@hidden so that you can conveniently define procedures that return
+procedures, up to any desired depth.
+
+For example,
address@hidden
+(define ((foo x) y)
+ (list x y))
address@hidden example
+is a convenience form of
address@hidden
+(define foo
+ (lambda (x)
+ (lambda (y)
+ (list x y))))
address@hidden example
+
address@hidden {Scheme Syntax} define (@dots{} (name args @dots{}) @dots{})
body @dots{}
address@hidden {Scheme Syntax} define* (@dots{} (name args @dots{}) @dots{})
body @dots{}
address@hidden {Scheme Syntax} define-public (@dots{} (name args @dots{})
@dots{}) body @dots{}
+
+Create a top level variable @var{name} bound to the procedure with
+parameter list @var{args}. If @var{name} is itself a formal parameter
+list, then a higher order procedure is created using that
+formal-parameter list, and returning a procedure that has parameter list
address@hidden This nesting may occur to arbitrary depth.
+
address@hidden is similar but the formal parameter lists take additional
+options as described in @ref{lambda* and define*}. For example,
address@hidden
+(define* ((foo #:keys (bar 'baz) (quux 'zot)) frotz #:rest rest)
+ (list bar quux frotz rest))
+
+((foo #:quux 'foo) 1 2 3 4 5)
address@hidden (baz foo 1 (2 3 4 5))
address@hidden example
+
address@hidden is similar to @code{define} but it also adds
address@hidden to the list of exported bindings of the current module.
address@hidden deffn
diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi
index c3da0c3..a1b3fe6 100644
--- a/doc/ref/guile.texi
+++ b/doc/ref/guile.texi
@@ -370,6 +370,7 @@ available through both Scheme and C interfaces.
* Expect:: Controlling interactive programs with Guile.
* sxml-match:: Pattern matching of SXML.
* The Scheme shell (scsh):: Using scsh interfaces in Guile.
+* Curried Definitions:: Extended @code{define} syntax.
@end menu
@include slib.texi
@@ -387,6 +388,7 @@ available through both Scheme and C interfaces.
@include sxml-match.texi
@include scsh.texi
address@hidden curried.texi
@node Standard Library
@chapter Standard Library
diff --git a/doc/ref/scheme-ideas.texi b/doc/ref/scheme-ideas.texi
index 53f7b61..15cf664 100644
--- a/doc/ref/scheme-ideas.texi
+++ b/doc/ref/scheme-ideas.texi
@@ -476,6 +476,11 @@ The corresponding forms of the alternative @code{define}
syntax are:
@noindent
For details on how these forms work, see @xref{Lambda}.
+Prior to Guile 2.0, Guile provided an extension to @code{define} syntax
+that allowed you to nest the previous extension up to an arbitrary
+depth. These are no longer provided by default, and instead have been
+moved to @ref{Curried Definitions}
+
(It could be argued that the alternative @code{define} forms are rather
confusing, especially for newcomers to the Scheme language, as they hide
both the role of @code{lambda} and the fact that procedures are values
diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi
index 3d43913..7eb84de 100644
--- a/doc/ref/scheme-using.texi
+++ b/doc/ref/scheme-using.texi
@@ -457,7 +457,7 @@ show a short error printout.
Default values for REPL options may be set using
@code{repl-default-option-set!} from @code{(system repl common)}:
address@hidden {Scheme Procedure} repl-set-default-option! key value
address@hidden {Scheme Procedure} repl-default-option-set! key value
Set the default value of a REPL option. This function is particularly
useful in a user's init file. @xref{Init File}.
@end deffn
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 29c1e06..da1b86f 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -54,6 +54,7 @@ get the relevant SRFI documents from the SRFI home page
* SRFI-69:: Basic hash tables.
* SRFI-88:: Keyword objects.
* SRFI-98:: Accessing environment variables.
+* SRFI-105:: Curly-infix expressions.
@end menu
@@ -3003,10 +3004,10 @@ with locale decimal point, eg.@: @samp{5.2}
@item @nicode{~z} @tab time zone, RFC-822 style
@item @nicode{~Z} @tab time zone symbol (not currently implemented)
@item @nicode{~1} @tab ISO-8601 date, @samp{~Y-~m-~d}
address@hidden @nicode{~2} @tab ISO-8601 time+zone, @samp{~k:~M:~S~z}
address@hidden @nicode{~3} @tab ISO-8601 time, @samp{~k:~M:~S}
address@hidden @nicode{~4} @tab ISO-8601 date/time+zone,
@samp{~Y-~m-~dT~k:~M:~S~z}
address@hidden @nicode{~5} @tab ISO-8601 date/time, @samp{~Y-~m-~dT~k:~M:~S}
address@hidden @nicode{~2} @tab ISO-8601 time+zone, @samp{~H:~M:~S~z}
address@hidden @nicode{~3} @tab ISO-8601 time, @samp{~H:~M:~S}
address@hidden @nicode{~4} @tab ISO-8601 date/time+zone,
@samp{~Y-~m-~dT~H:~M:~S~z}
address@hidden @nicode{~5} @tab ISO-8601 date/time, @samp{~Y-~m-~dT~H:~M:~S}
@end multitable
@end defun
@@ -4469,6 +4470,56 @@ Returns the names and values of all the environment
variables as an
association list in which both the keys and the values are strings.
@end deffn
address@hidden SRFI-105
address@hidden SRFI-105 Curly-infix expressions.
address@hidden SRFI-105
address@hidden curly-infix
address@hidden curly-infix-and-bracket-lists
+
+Guile's built-in reader includes support for SRFI-105 curly-infix
+expressions. See @uref{http://srfi.schemers.org/srfi-105/srfi-105.html,
+the specification of SRFI-105}. Some examples:
+
address@hidden
address@hidden <= address@hidden @result{} (<= n 5)
address@hidden + b + address@hidden @result{} (+ a b c)
address@hidden * @{b + address@hidden@} @result{} (* a (+ b c))
address@hidden(- a) / address@hidden @result{} (/ (- a) b)
address@hidden(a) / address@hidden @result{} (/ (- a) b) as well
address@hidden(f a b) + (g h)@} @result{} (+ (f a b) (g h))
address@hidden(a b) + g(h)@} @result{} (+ (f a b) (g h)) as well
address@hidden b] + g(h)@} @result{} (+ ($bracket-apply$ f a b) (g h))
+'@{a + f(b) + address@hidden @result{} '(+ a (f b) x)
address@hidden(x) >= address@hidden @result{} (>= (length x) 6)
address@hidden + address@hidden @result{} (+ n-1 n-2)
address@hidden * address@hidden - address@hidden@} @result{} (* n (factorial
(- n 1)))
address@hidden@{a > address@hidden and @{b >= address@hidden@} @result{} (and
(> a 0) (>= b 1))
address@hidden@{n - address@hidden(x)@} @result{} ((f (- n 1)) x)
address@hidden . address@hidden @result{} ($nfx$ a . z)
address@hidden + b - address@hidden @result{} ($nfx$ a + b - c)
address@hidden example
+
+To enable curly-infix expressions within a file, place the reader
+directive @code{#!curly-infix} before the first use of curly-infix
+notation. To globally enable curly-infix expressions in Guile's reader,
+set the @code{curly-infix} read option.
+
+Guile also implements the following non-standard extension to SRFI-105:
+if @code{curly-infix} is enabled and there is no other meaning assigned
+to square brackets (i.e. the @code{square-brackets} read option is
+turned off), then lists within square brackets are read as normal lists
+but with the special symbol @code{$bracket-list$} added to the front.
+To enable this combination of read options within a file, use the reader
+directive @code{#!curly-infix-and-bracket-lists}. For example:
+
address@hidden
+[a b] @result{} ($bracket-list$ a b)
+[a . b] @result{} ($bracket-list$ a . b)
address@hidden example
+
+
+For more information on reader options, @xref{Scheme Read}.
+
@c srfi-modules.texi ends here
@c Local Variables:
diff --git a/doc/ref/tour.texi b/doc/ref/tour.texi
index 3e61269..0924216 100644
--- a/doc/ref/tour.texi
+++ b/doc/ref/tour.texi
@@ -1,7 +1,7 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006,
2010, 2011
address@hidden Free Software Foundation, Inc.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006,
2010, 2011,
address@hidden 2012 Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@raisesections
@@ -149,7 +149,7 @@ that makes the @code{j0} function available to Scheme code.
SCM
j0_wrapper (SCM x)
@{
- return scm_make_real (j0 (scm_num2dbl (x, "j0")));
+ return scm_from_double (j0 (scm_to_double (x)));
@}
void
diff --git a/libguile/arrays.c b/libguile/arrays.c
index f0f9012..83d7db2 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -1,4 +1,5 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006,
2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004,2005,
+ * 2006, 2009, 2010, 2011, 2012 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
@@ -814,178 +815,6 @@ scm_i_print_array (SCM array, SCM port, scm_print_state
*pstate)
return scm_i_print_array_dimension (&h, 0, 0, port, pstate);
}
-/* Read an array. This function can also read vectors and uniform
- vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
- handled here.
-
- C is the first character read after the '#'.
-*/
-
-static int
-read_decimal_integer (SCM port, int c, ssize_t *resp)
-{
- ssize_t sign = 1;
- ssize_t res = 0;
- int got_it = 0;
-
- if (c == '-')
- {
- sign = -1;
- c = scm_getc_unlocked (port);
- }
-
- while ('0' <= c && c <= '9')
- {
- res = 10*res + c-'0';
- got_it = 1;
- c = scm_getc_unlocked (port);
- }
-
- if (got_it)
- *resp = sign * res;
- return c;
-}
-
-SCM
-scm_i_read_array (SCM port, int c)
-{
- ssize_t rank;
- scm_t_wchar tag_buf[8];
- int tag_len;
-
- SCM tag, shape = SCM_BOOL_F, elements;
-
- /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
- the array code can not deal with zero-length dimensions yet, and
- we want to allow zero-length vectors, of course.
- */
- if (c == '(')
- {
- scm_ungetc_unlocked (c, port);
- return scm_vector (scm_read (port));
- }
-
- /* Disambiguate between '#f' and uniform floating point vectors.
- */
- if (c == 'f')
- {
- c = scm_getc_unlocked (port);
- if (c != '3' && c != '6')
- {
- if (c != EOF)
- scm_ungetc_unlocked (c, port);
- return SCM_BOOL_F;
- }
- rank = 1;
- tag_buf[0] = 'f';
- tag_len = 1;
- goto continue_reading_tag;
- }
-
- /* Read rank.
- */
- rank = 1;
- c = read_decimal_integer (port, c, &rank);
- if (rank < 0)
- scm_i_input_error (NULL, port, "array rank must be non-negative",
- SCM_EOL);
-
- /* Read tag.
- */
- tag_len = 0;
- continue_reading_tag:
- while (c != EOF && c != '(' && c != '@' && c != ':'
- && tag_len < sizeof tag_buf / sizeof tag_buf[0])
- {
- tag_buf[tag_len++] = c;
- c = scm_getc_unlocked (port);
- }
- if (tag_len == 0)
- tag = SCM_BOOL_T;
- else
- {
- tag = scm_string_to_symbol (scm_from_utf32_stringn (tag_buf, tag_len));
- if (tag_len == sizeof tag_buf / sizeof tag_buf[0])
- scm_i_input_error (NULL, port, "invalid array tag, starting with: ~a",
- scm_list_1 (tag));
- }
-
- /* Read shape.
- */
- if (c == '@' || c == ':')
- {
- shape = SCM_EOL;
-
- do
- {
- ssize_t lbnd = 0, len = 0;
- SCM s;
-
- if (c == '@')
- {
- c = scm_getc_unlocked (port);
- c = read_decimal_integer (port, c, &lbnd);
- }
-
- s = scm_from_ssize_t (lbnd);
-
- if (c == ':')
- {
- c = scm_getc_unlocked (port);
- c = read_decimal_integer (port, c, &len);
- if (len < 0)
- scm_i_input_error (NULL, port,
- "array length must be non-negative",
- SCM_EOL);
-
- s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1));
- }
-
- shape = scm_cons (s, shape);
- } while (c == '@' || c == ':');
-
- shape = scm_reverse_x (shape, SCM_EOL);
- }
-
- /* Read nested lists of elements.
- */
- if (c != '(')
- scm_i_input_error (NULL, port,
- "missing '(' in vector or array literal",
- SCM_EOL);
- scm_ungetc_unlocked (c, port);
- elements = scm_read (port);
-
- if (scm_is_false (shape))
- shape = scm_from_ssize_t (rank);
- else if (scm_ilength (shape) != rank)
- scm_i_input_error
- (NULL, port,
- "the number of shape specifications must match the array rank",
- SCM_EOL);
-
- /* Handle special print syntax of rank zero arrays; see
- scm_i_print_array for a rationale.
- */
- if (rank == 0)
- {
- if (!scm_is_pair (elements))
- scm_i_input_error (NULL, port,
- "too few elements in array literal, need 1",
- SCM_EOL);
- if (!scm_is_null (SCM_CDR (elements)))
- scm_i_input_error (NULL, port,
- "too many elements in array literal, want 1",
- SCM_EOL);
- elements = SCM_CAR (elements);
- }
-
- /* Construct array.
- */
- return scm_list_to_typed_array (tag, shape, elements);
-}
-
-
static SCM
array_handle_ref (scm_t_array_handle *h, size_t pos)
{
diff --git a/libguile/arrays.h b/libguile/arrays.h
index 5ea604d..6045ab6 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -3,7 +3,8 @@
#ifndef SCM_ARRAY_H
#define SCM_ARRAY_H
-/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009, 2010
Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009,
+ * 2010, 2012 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
@@ -73,7 +74,6 @@ typedef struct scm_i_t_array
SCM_INTERNAL SCM scm_i_make_array (int ndim);
SCM_INTERNAL int scm_i_print_array (SCM array, SCM port, scm_print_state
*pstate);
-SCM_INTERNAL SCM scm_i_read_array (SCM port, int c);
SCM_INTERNAL void scm_init_arrays (void);
diff --git a/libguile/hash.c b/libguile/hash.c
index d47c7e0..740dac1 100644
--- a/libguile/hash.c
+++ b/libguile/hash.c
@@ -1,4 +1,5 @@
-/* Copyright (C) 1995,1996,1997, 2000, 2001, 2003, 2004, 2006, 2008, 2009,
2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1997, 2000, 2001, 2003, 2004, 2006, 2008,
+ * 2009, 2010, 2011, 2012 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
@@ -223,6 +224,53 @@ scm_i_utf8_string_hash (const char *str, size_t len)
return ret;
}
+static unsigned long scm_raw_ihashq (scm_t_bits key);
+static unsigned long scm_raw_ihash (SCM obj, size_t depth);
+
+/* Return the hash of struct OBJ. Traverse OBJ's fields to compute the
+ result, unless DEPTH is zero. Assumes that OBJ is a struct. */
+static unsigned long
+scm_i_struct_hash (SCM obj, size_t depth)
+{
+ SCM layout;
+ scm_t_bits *data;
+ size_t struct_size, field_num;
+ unsigned long hash;
+
+ layout = SCM_STRUCT_LAYOUT (obj);
+ struct_size = scm_i_symbol_length (layout) / 2;
+ data = SCM_STRUCT_DATA (obj);
+
+ hash = scm_raw_ihashq (SCM_UNPACK (SCM_STRUCT_VTABLE (obj)));
+ if (depth > 0)
+ for (field_num = 0; field_num < struct_size; field_num++)
+ {
+ int protection;
+
+ protection = scm_i_symbol_ref (layout, field_num * 2 + 1);
+ if (protection != 'h' && protection != 'o')
+ {
+ int type;
+ type = scm_i_symbol_ref (layout, field_num * 2);
+ switch (type)
+ {
+ case 'p':
+ hash ^= scm_raw_ihash (SCM_PACK (data[field_num]),
+ depth / 2);
+ break;
+ case 'u':
+ hash ^= scm_raw_ihashq (data[field_num]);
+ break;
+ default:
+ /* Ignore 's' fields. */;
+ }
+ }
+ }
+
+ /* FIXME: Tail elements should be taken into account. */
+
+ return hash;
+}
/* Thomas Wang's integer hasher, from
http://www.cris.com/~Ttwang/tech/inthash.htm. */
@@ -298,6 +346,8 @@ scm_raw_ihash (SCM obj, size_t depth)
^ scm_raw_ihash (SCM_CDR (obj), depth / 2));
else
return scm_raw_ihashq (scm_tc3_cons);
+ case scm_tcs_struct:
+ return scm_i_struct_hash (obj, depth);
default:
return scm_raw_ihashq (SCM_CELL_WORD_0 (obj));
}
diff --git a/libguile/list.c b/libguile/list.c
index 8297b17..6276403 100644
--- a/libguile/list.c
+++ b/libguile/list.c
@@ -267,7 +267,7 @@ SCM_DEFINE (scm_append, "append", 0, 0, 1,
SCM_DEFINE (scm_append_x, "append!", 0, 0, 1,
- (SCM lists),
+ (SCM args),
"A destructive version of @code{append} (@pxref{Pairs and\n"
"Lists,,,r5rs, The Revised^5 Report on Scheme}). The cdr field\n"
"of each list's final pair is changed to point to the head of\n"
@@ -276,26 +276,29 @@ SCM_DEFINE (scm_append_x, "append!", 0, 0, 1,
#define FUNC_NAME s_scm_append_x
{
SCM ret, *loc;
- SCM_VALIDATE_REST_ARGUMENT (lists);
+ int argnum = 1;
+ SCM_VALIDATE_REST_ARGUMENT (args);
- if (scm_is_null (lists))
+ if (scm_is_null (args))
return SCM_EOL;
loc = &ret;
for (;;)
{
- SCM arg = SCM_CAR (lists);
+ SCM arg = SCM_CAR (args);
*loc = arg;
- lists = SCM_CDR (lists);
- if (scm_is_null (lists))
+ args = SCM_CDR (args);
+ if (scm_is_null (args))
return ret;
if (!SCM_NULL_OR_NIL_P (arg))
{
- SCM_VALIDATE_CONS (SCM_ARG1, arg);
+ SCM_VALIDATE_CONS (argnum, arg);
loc = SCM_CDRLOC (scm_last_pair (arg));
+ SCM_VALIDATE_NULL_OR_NIL (argnum, *loc);
}
+ argnum++;
}
}
#undef FUNC_NAME
diff --git a/libguile/ports.c b/libguile/ports.c
index 11142ba..e7187d3 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -613,6 +613,8 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned
long mode_bits,
entry->ilseq_handler = handler;
entry->iconv_descriptors = NULL;
+ entry->alist = SCM_EOL;
+
if (SCM_PORT_DESCRIPTOR (ret)->free)
scm_i_set_finalizer (SCM2PTR (ret), finalize_port, NULL);
@@ -2370,7 +2372,7 @@ scm_lfwrite_substr (SCM str, size_t start, size_t end,
SCM port)
if (end == (size_t) -1)
end = scm_i_string_length (str);
- scm_display (scm_c_substring (str, start, end), port);
+ scm_i_display_substring (str, start, end, port);
if (pt->rw_random)
pt->rw_active = SCM_PORT_WRITE;
diff --git a/libguile/ports.h b/libguile/ports.h
index 92e388e..c1ba719 100644
--- a/libguile/ports.h
+++ b/libguile/ports.h
@@ -132,6 +132,10 @@ typedef struct
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;
diff --git a/libguile/print.c b/libguile/print.c
index 90bc9ad..5d5c56d 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -1229,6 +1229,29 @@ write_character (scm_t_wchar ch, SCM port, int
string_escapes_p)
write_character_escaped (ch, string_escapes_p, port);
}
+/* Display STR to PORT from START inclusive to END exclusive. */
+void
+scm_i_display_substring (SCM str, size_t start, size_t end, SCM port)
+{
+ int narrow_p;
+ const char *buf;
+ size_t len, printed;
+
+ buf = scm_i_string_data (str);
+ len = end - start;
+ narrow_p = scm_i_is_narrow_string (str);
+ buf += start * (narrow_p ? sizeof (char) : sizeof (scm_t_wchar));
+
+ printed = display_string (buf, narrow_p, end - start, port,
+ PORT_CONVERSION_HANDLER (port));
+
+ if (SCM_UNLIKELY (printed < len))
+ scm_encoding_error (__func__, errno,
+ "cannot convert to output locale",
+ port, scm_c_string_ref (str, printed + start));
+}
+
+
/* Print an integer.
*/
diff --git a/libguile/print.h b/libguile/print.h
index 4a3c2f5..80a9922 100644
--- a/libguile/print.h
+++ b/libguile/print.h
@@ -3,7 +3,8 @@
#ifndef SCM_PRINT_H
#define SCM_PRINT_H
-/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2004, 2006, 2008, 2010, 2012
Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1998, 2000, 2001, 2003, 2004, 2006, 2008,
+ * 2010, 2012 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
@@ -78,6 +79,8 @@ SCM_API SCM scm_print_options (SCM setting);
SCM_API SCM scm_make_print_state (void);
SCM_API void scm_free_print_state (SCM print_state);
SCM_INTERNAL SCM scm_i_port_with_print_state (SCM port, SCM print_state);
+SCM_INTERNAL void scm_i_display_substring (SCM str, size_t start, size_t end,
+ SCM port);
SCM_API void scm_intprint (scm_t_intmax n, int radix, SCM port);
SCM_API void scm_uintprint (scm_t_uintmax n, int radix, SCM port);
SCM_API void scm_ipruk (char *hdr, SCM ptr, SCM port);
diff --git a/libguile/private-options.h b/libguile/private-options.h
index 9d2d43c..ed0f314 100644
--- a/libguile/private-options.h
+++ b/libguile/private-options.h
@@ -67,7 +67,8 @@ SCM_INTERNAL scm_t_option scm_read_opts[];
#define SCM_R6RS_ESCAPES_P scm_read_opts[4].val
#define SCM_SQUARE_BRACKETS_P scm_read_opts[5].val
#define SCM_HUNGRY_EOL_ESCAPES_P scm_read_opts[6].val
+#define SCM_CURLY_INFIX_P scm_read_opts[7].val
-#define SCM_N_READ_OPTIONS 6
+#define SCM_N_READ_OPTIONS 7
#endif /* PRIVATE_OPTIONS */
diff --git a/libguile/read.c b/libguile/read.c
index 5738e2e..d977cff 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -63,24 +63,59 @@ SCM_SYMBOL (scm_keyword_prefix, "prefix");
SCM_SYMBOL (scm_keyword_postfix, "postfix");
SCM_SYMBOL (sym_nil, "nil");
-scm_t_option scm_read_opts[] = {
- { SCM_OPTION_BOOLEAN, "copy", 0,
- "Copy source code expressions." },
- { SCM_OPTION_BOOLEAN, "positions", 1,
- "Record positions of source code expressions." },
- { SCM_OPTION_BOOLEAN, "case-insensitive", 0,
- "Convert symbols to lower case."},
- { SCM_OPTION_SCM, "keywords", (scm_t_bits) SCM_BOOL_F_BITS,
- "Style of keyword recognition: #f, 'prefix or 'postfix."},
- { SCM_OPTION_BOOLEAN, "r6rs-hex-escapes", 0,
- "Use R6RS variable-length character and string hex escapes."},
- { SCM_OPTION_BOOLEAN, "square-brackets", 1,
- "Treat `[' and `]' as parentheses, for R6RS compatibility."},
- { SCM_OPTION_BOOLEAN, "hungry-eol-escapes", 0,
- "In strings, consume leading whitespace after an escaped end-of-line."},
- { 0, },
+/* SRFI-105 curly infix expression support */
+SCM_SYMBOL (sym_nfx, "$nfx$");
+SCM_SYMBOL (sym_bracket_list, "$bracket-list$");
+SCM_SYMBOL (sym_bracket_apply, "$bracket-apply$");
+
+scm_t_option scm_read_opts[] =
+ {
+ { SCM_OPTION_BOOLEAN, "copy", 0,
+ "Copy source code expressions." },
+ { SCM_OPTION_BOOLEAN, "positions", 1,
+ "Record positions of source code expressions." },
+ { SCM_OPTION_BOOLEAN, "case-insensitive", 0,
+ "Convert symbols to lower case."},
+ { SCM_OPTION_SCM, "keywords", (scm_t_bits) SCM_BOOL_F_BITS,
+ "Style of keyword recognition: #f, 'prefix or 'postfix."},
+ { SCM_OPTION_BOOLEAN, "r6rs-hex-escapes", 0,
+ "Use R6RS variable-length character and string hex escapes."},
+ { SCM_OPTION_BOOLEAN, "square-brackets", 1,
+ "Treat `[' and `]' as parentheses, for R6RS compatibility."},
+ { SCM_OPTION_BOOLEAN, "hungry-eol-escapes", 0,
+ "In strings, consume leading whitespace after an escaped end-of-line."},
+ { SCM_OPTION_BOOLEAN, "curly-infix", 0,
+ "Support SRFI-105 curly infix expressions."},
+ { 0, },
+ };
+
+/* Internal read options structure. This is initialized by 'scm_read'
+ from the global and per-port read options, and a pointer is passed
+ down to all helper functions. */
+
+enum t_keyword_style
+ {
+ KEYWORD_STYLE_HASH_PREFIX,
+ KEYWORD_STYLE_PREFIX,
+ KEYWORD_STYLE_POSTFIX
+ };
+
+struct t_read_opts
+{
+ enum t_keyword_style keyword_style;
+ unsigned int copy_source_p : 1;
+ unsigned int record_positions_p : 1;
+ unsigned int case_insensitive_p : 1;
+ unsigned int r6rs_escapes_p : 1;
+ unsigned int square_brackets_p : 1;
+ unsigned int hungry_eol_escapes_p : 1;
+ unsigned int curly_infix_p : 1;
+ unsigned int neoteric_p : 1;
};
+typedef struct t_read_opts scm_t_read_opts;
+
+
/*
Give meaningful error messages for errors
@@ -167,6 +202,9 @@ scm_i_read_hash_procedures_set_x (SCM value)
/* The maximum size of Scheme character names. */
#define READER_CHAR_NAME_MAX_SIZE 50
+/* The maximum size of reader directive names. */
+#define READER_DIRECTIVE_NAME_MAX_SIZE 50
+
/* `isblank' is only in C99. */
#define CHAR_IS_BLANK_(_chr) \
@@ -185,10 +223,13 @@ scm_i_read_hash_procedures_set_x (SCM value)
structure''). */
#define CHAR_IS_R5RS_DELIMITER(c) \
(CHAR_IS_BLANK (c) \
- || (c == ')') || (c == '(') || (c == ';') || (c == '"') \
- || (SCM_SQUARE_BRACKETS_P && ((c == '[') || (c == ']'))))
+ || (c) == ')' || (c) == '(' || (c) == ';' || (c) == '"')
-#define CHAR_IS_DELIMITER CHAR_IS_R5RS_DELIMITER
+#define CHAR_IS_DELIMITER(c) \
+ (CHAR_IS_R5RS_DELIMITER (c) \
+ || (((c) == ']' || (c) == '[') && (opts->square_brackets_p \
+ || opts->curly_infix_p)) \
+ || (((c) == '}' || (c) == '{') && opts->curly_infix_p))
/* Exponent markers, as defined in section 7.1.1 of R5RS, ``Lexical
Structure''. */
@@ -199,8 +240,8 @@ scm_i_read_hash_procedures_set_x (SCM value)
/* Read an SCSH block comment. */
static SCM scm_read_scsh_block_comment (scm_t_wchar, SCM);
static SCM scm_read_r6rs_block_comment (scm_t_wchar, SCM);
-static SCM scm_read_commented_expression (scm_t_wchar, SCM);
-static SCM scm_read_shebang (scm_t_wchar, SCM);
+static SCM scm_read_commented_expression (scm_t_wchar, SCM, scm_t_read_opts *);
+static SCM scm_read_shebang (scm_t_wchar, SCM, scm_t_read_opts *);
static SCM scm_get_hash_procedure (int);
/* Read from PORT until a delimiter (e.g., a whitespace) is read. Put the
@@ -208,7 +249,8 @@ static SCM scm_get_hash_procedure (int);
fewer than BUF_SIZE bytes, non-zero otherwise. READ will be set the number
of
bytes actually read. */
static int
-read_token (SCM port, char *buf, size_t buf_size, size_t *read)
+read_token (SCM port, scm_t_read_opts *opts,
+ char *buf, size_t buf_size, size_t *read)
{
*read = 0;
@@ -238,8 +280,8 @@ read_token (SCM port, char *buf, size_t buf_size, size_t
*read)
/* Like `read_token', but return either BUFFER, or a GC-allocated buffer
if the token doesn't fit in BUFFER_SIZE bytes. */
static char *
-read_complete_token (SCM port, char *buffer, size_t buffer_size,
- size_t *read)
+read_complete_token (SCM port, scm_t_read_opts *opts,
+ char *buffer, size_t buffer_size, size_t *read)
{
int overflow = 0;
size_t bytes_read, overflow_size = 0;
@@ -247,7 +289,7 @@ read_complete_token (SCM port, char *buffer, size_t
buffer_size,
do
{
- overflow = read_token (port, buffer, buffer_size, &bytes_read);
+ overflow = read_token (port, opts, buffer, buffer_size, &bytes_read);
if (bytes_read == 0)
break;
if (overflow || overflow_size != 0)
@@ -284,7 +326,7 @@ read_complete_token (SCM port, char *buffer, size_t
buffer_size,
/* Skip whitespace from PORT and return the first non-whitespace character
read. Raise an error on end-of-file. */
static int
-flush_ws (SCM port, const char *eoferr)
+flush_ws (SCM port, scm_t_read_opts *opts, const char *eoferr)
{
scm_t_wchar c;
while (1)
@@ -321,10 +363,10 @@ flush_ws (SCM port, const char *eoferr)
eoferr = "read_sharp";
goto goteof;
case '!':
- scm_read_shebang (c, port);
+ scm_read_shebang (c, port, opts);
break;
case ';':
- scm_read_commented_expression (c, port);
+ scm_read_commented_expression (c, port, opts);
break;
case '|':
if (scm_is_false (scm_get_hash_procedure (c)))
@@ -355,44 +397,49 @@ flush_ws (SCM port, const char *eoferr)
/* Token readers. */
-static SCM scm_read_expression (SCM port);
-static SCM scm_read_sharp (int chr, SCM port, long line, int column);
+static SCM scm_read_expression (SCM port, scm_t_read_opts *opts);
+static SCM scm_read_sharp (int chr, SCM port, scm_t_read_opts *opts,
+ long line, int column);
static SCM
-maybe_annotate_source (SCM x, SCM port, long line, int column)
+maybe_annotate_source (SCM x, SCM port, scm_t_read_opts *opts,
+ long line, int column)
{
- if (SCM_RECORD_POSITIONS_P)
+ if (opts->record_positions_p)
scm_i_set_source_properties_x (x, line, column, SCM_FILENAME (port));
return x;
}
static SCM
-scm_read_sexp (scm_t_wchar chr, SCM port)
+scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
#define FUNC_NAME "scm_i_lreadparen"
{
int c;
SCM tmp, tl, ans = SCM_EOL;
- const int terminating_char = ((chr == '[') ? ']' : ')');
+ const int curly_list_p = (chr == '{') && opts->curly_infix_p;
+ const int terminating_char = ((chr == '{') ? '}'
+ : ((chr == '[') ? ']'
+ : ')'));
/* Need to capture line and column numbers here. */
long line = SCM_LINUM (port);
int column = SCM_COL (port) - 1;
- c = flush_ws (port, FUNC_NAME);
+ c = flush_ws (port, opts, FUNC_NAME);
if (terminating_char == c)
return SCM_EOL;
scm_ungetc_unlocked (c, port);
- tmp = scm_read_expression (port);
+ tmp = scm_read_expression (port, opts);
/* Note that it is possible for scm_read_expression to return
scm_sym_dot, but not as part of a dotted pair: as in #{.}#. So
check that it's a real dot by checking `c'. */
if (c == '.' && scm_is_eq (scm_sym_dot, tmp))
{
- ans = scm_read_expression (port);
- if (terminating_char != (c = flush_ws (port, FUNC_NAME)))
+ ans = scm_read_expression (port, opts);
+ if (terminating_char != (c = flush_ws (port, opts, FUNC_NAME)))
scm_i_input_error (FUNC_NAME, port, "missing close paren",
SCM_EOL);
return ans;
@@ -401,28 +448,29 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
/* Build the head of the list structure. */
ans = tl = scm_cons (tmp, SCM_EOL);
- while (terminating_char != (c = flush_ws (port, FUNC_NAME)))
+ while (terminating_char != (c = flush_ws (port, opts, FUNC_NAME)))
{
SCM new_tail;
- if (c == ')' || (SCM_SQUARE_BRACKETS_P && c == ']'))
+ if (c == ')' || (c == ']' && opts->square_brackets_p)
+ || ((c == '}' || c == ']') && opts->curly_infix_p))
scm_i_input_error (FUNC_NAME, port,
"in pair: mismatched close paren: ~A",
scm_list_1 (SCM_MAKE_CHAR (c)));
scm_ungetc_unlocked (c, port);
- tmp = scm_read_expression (port);
+ tmp = scm_read_expression (port, opts);
/* See above note about scm_sym_dot. */
if (c == '.' && scm_is_eq (scm_sym_dot, tmp))
{
- SCM_SETCDR (tl, scm_read_expression (port));
+ SCM_SETCDR (tl, scm_read_expression (port, opts));
- c = flush_ws (port, FUNC_NAME);
+ c = flush_ws (port, opts, FUNC_NAME);
if (terminating_char != c)
scm_i_input_error (FUNC_NAME, port,
"in pair: missing close paren", SCM_EOL);
- goto exit;
+ break;
}
new_tail = scm_cons (tmp, SCM_EOL);
@@ -430,8 +478,60 @@ scm_read_sexp (scm_t_wchar chr, SCM port)
tl = new_tail;
}
- exit:
- return maybe_annotate_source (ans, port, line, column);
+ if (curly_list_p)
+ {
+ /* In addition to finding the length, 'scm_ilength' checks for
+ improper or circular lists, in which case it returns -1. */
+ int len = scm_ilength (ans);
+
+ /* The (len == 0) case is handled above */
+ if (len == 1)
+ /* Return directly to avoid re-annotating the element's source
+ location with the position of the outer brace. Also, it
+ might not be possible to annotate the element. */
+ return scm_car (ans); /* {e} => e */
+ else if (len == 2)
+ ; /* Leave the list unchanged: {e1 e2} => (e1 e2) */
+ else if (len >= 3 && (len & 1))
+ {
+ /* It's a proper list whose length is odd and at least 3. If
+ the elements at odd indices (the infix operator positions)
+ are all 'equal?', then it's a simple curly-infix list.
+ Otherwise it's a mixed curly-infix list. */
+ SCM op = scm_cadr (ans);
+
+ /* Check to see if the elements at odd indices are 'equal?' */
+ for (tl = scm_cdddr (ans); ; tl = scm_cddr (tl))
+ {
+ if (scm_is_null (tl))
+ {
+ /* Convert simple curly-infix list to prefix:
+ {a <op> b <op> ...} => (<op> a b ...) */
+ tl = ans;
+ while (scm_is_pair (scm_cdr (tl)))
+ {
+ tmp = scm_cddr (tl);
+ SCM_SETCDR (tl, tmp);
+ tl = tmp;
+ }
+ ans = scm_cons (op, ans);
+ break;
+ }
+ else if (scm_is_false (scm_equal_p (op, scm_car (tl))))
+ {
+ /* Mixed curly-infix list: {e ...} => ($nfx$ e ...) */
+ ans = scm_cons (sym_nfx, ans);
+ break;
+ }
+ }
+ }
+ else
+ /* Mixed curly-infix (possibly improper) list:
+ {e . tail} => ($nfx$ e . tail) */
+ ans = scm_cons (sym_nfx, ans);
+ }
+
+ return maybe_annotate_source (ans, port, opts, line, column);
}
#undef FUNC_NAME
@@ -487,7 +587,7 @@ skip_intraline_whitespace (SCM port)
}
static SCM
-scm_read_string (int chr, SCM port)
+scm_read_string (int chr, SCM port, scm_t_read_opts *opts)
#define FUNC_NAME "scm_lreadr"
{
/* For strings smaller than C_STR, this function creates only one Scheme
@@ -526,7 +626,7 @@ scm_read_string (int chr, SCM port)
case '\\':
break;
case '\n':
- if (SCM_HUNGRY_EOL_ESCAPES_P)
+ if (opts->hungry_eol_escapes_p)
skip_intraline_whitespace (port);
continue;
case '0':
@@ -554,19 +654,19 @@ scm_read_string (int chr, SCM port)
c = '\010';
break;
case 'x':
- if (SCM_R6RS_ESCAPES_P)
+ if (opts->r6rs_escapes_p)
SCM_READ_HEX_ESCAPE (10, ';');
else
SCM_READ_HEX_ESCAPE (2, '\0');
break;
case 'u':
- if (!SCM_R6RS_ESCAPES_P)
+ if (!opts->r6rs_escapes_p)
{
SCM_READ_HEX_ESCAPE (4, '\0');
break;
}
case 'U':
- if (!SCM_R6RS_ESCAPES_P)
+ if (!opts->r6rs_escapes_p)
{
SCM_READ_HEX_ESCAPE (6, '\0');
break;
@@ -593,13 +693,13 @@ scm_read_string (int chr, SCM port)
str = scm_string_concatenate_reverse (str, SCM_UNDEFINED, SCM_UNDEFINED);
}
- return maybe_annotate_source (str, port, line, column);
+ return maybe_annotate_source (str, port, opts, line, column);
}
#undef FUNC_NAME
static SCM
-scm_read_number (scm_t_wchar chr, SCM port)
+scm_read_number (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
{
SCM result, str = SCM_EOL;
char local_buffer[READER_BUFFER_SIZE], *buffer;
@@ -611,7 +711,7 @@ scm_read_number (scm_t_wchar chr, SCM port)
int column = SCM_COL (port) - 1;
scm_ungetc_unlocked (chr, port);
- buffer = read_complete_token (port, local_buffer, sizeof local_buffer,
+ buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer,
&bytes_read);
str = scm_from_stringn (buffer, bytes_read, pt->encoding, pt->ilseq_handler);
@@ -620,30 +720,30 @@ scm_read_number (scm_t_wchar chr, SCM port)
if (scm_is_false (result))
{
/* Return a symbol instead of a number */
- if (SCM_CASE_INSENSITIVE_P)
+ if (opts->case_insensitive_p)
str = scm_string_downcase_x (str);
result = scm_string_to_symbol (str);
}
else if (SCM_NIMP (result))
- result = maybe_annotate_source (result, port, line, column);
+ result = maybe_annotate_source (result, port, opts, line, column);
SCM_COL (port) += scm_i_string_length (str);
return result;
}
static SCM
-scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port)
+scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
{
SCM result;
int ends_with_colon = 0;
size_t bytes_read;
- int postfix = scm_is_eq (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_postfix);
+ int postfix = (opts->keyword_style == KEYWORD_STYLE_POSTFIX);
char local_buffer[READER_BUFFER_SIZE], *buffer;
scm_t_port *pt = SCM_PTAB_ENTRY (port);
SCM str;
scm_ungetc_unlocked (chr, port);
- buffer = read_complete_token (port, local_buffer, sizeof local_buffer,
+ buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer,
&bytes_read);
if (bytes_read > 0)
ends_with_colon = buffer[bytes_read - 1] == ':';
@@ -653,7 +753,7 @@ scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port)
str = scm_from_stringn (buffer, bytes_read - 1,
pt->encoding, pt->ilseq_handler);
- if (SCM_CASE_INSENSITIVE_P)
+ if (opts->case_insensitive_p)
str = scm_string_downcase_x (str);
result = scm_symbol_to_keyword (scm_string_to_symbol (str));
}
@@ -662,7 +762,7 @@ scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port)
str = scm_from_stringn (buffer, bytes_read,
pt->encoding, pt->ilseq_handler);
- if (SCM_CASE_INSENSITIVE_P)
+ if (opts->case_insensitive_p)
str = scm_string_downcase_x (str);
result = scm_string_to_symbol (str);
}
@@ -672,7 +772,7 @@ scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port)
}
static SCM
-scm_read_number_and_radix (scm_t_wchar chr, SCM port)
+scm_read_number_and_radix (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
#define FUNC_NAME "scm_lreadr"
{
SCM result;
@@ -710,7 +810,7 @@ scm_read_number_and_radix (scm_t_wchar chr, SCM port)
radix = 10;
}
- buffer = read_complete_token (port, local_buffer, sizeof local_buffer,
+ buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer,
&read);
pt = SCM_PTAB_ENTRY (port);
@@ -730,7 +830,7 @@ scm_read_number_and_radix (scm_t_wchar chr, SCM port)
#undef FUNC_NAME
static SCM
-scm_read_quote (int chr, SCM port)
+scm_read_quote (int chr, SCM port, scm_t_read_opts *opts)
{
SCM p;
long line = SCM_LINUM (port);
@@ -767,8 +867,8 @@ scm_read_quote (int chr, SCM port)
abort ();
}
- p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
- return maybe_annotate_source (p, port, line, column);
+ p = scm_cons2 (p, scm_read_expression (port, opts), SCM_EOL);
+ return maybe_annotate_source (p, port, opts, line, column);
}
SCM_SYMBOL (sym_syntax, "syntax");
@@ -777,7 +877,7 @@ SCM_SYMBOL (sym_unsyntax, "unsyntax");
SCM_SYMBOL (sym_unsyntax_splicing, "unsyntax-splicing");
static SCM
-scm_read_syntax (int chr, SCM port)
+scm_read_syntax (int chr, SCM port, scm_t_read_opts *opts)
{
SCM p;
long line = SCM_LINUM (port);
@@ -814,14 +914,14 @@ scm_read_syntax (int chr, SCM port)
abort ();
}
- p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
- return maybe_annotate_source (p, port, line, column);
+ p = scm_cons2 (p, scm_read_expression (port, opts), SCM_EOL);
+ return maybe_annotate_source (p, port, opts, line, column);
}
static SCM
-scm_read_nil (int chr, SCM port)
+scm_read_nil (int chr, SCM port, scm_t_read_opts *opts)
{
- SCM id = scm_read_mixed_case_symbol (chr, port);
+ SCM id = scm_read_mixed_case_symbol (chr, port, opts);
if (!scm_is_eq (id, sym_nil))
scm_i_input_error ("scm_read_nil", port,
@@ -867,7 +967,7 @@ scm_read_boolean (int chr, SCM port)
}
static SCM
-scm_read_character (scm_t_wchar chr, SCM port)
+scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
#define FUNC_NAME "scm_lreadr"
{
char buffer[READER_CHAR_NAME_MAX_SIZE];
@@ -877,7 +977,8 @@ scm_read_character (scm_t_wchar chr, SCM port)
int overflow;
scm_t_port *pt;
- overflow = read_token (port, buffer, READER_CHAR_NAME_MAX_SIZE, &bytes_read);
+ overflow = read_token (port, opts, buffer, READER_CHAR_NAME_MAX_SIZE,
+ &bytes_read);
if (overflow)
scm_i_input_error (FUNC_NAME, port, "character name too long", SCM_EOL);
@@ -973,7 +1074,7 @@ scm_read_character (scm_t_wchar chr, SCM port)
#undef FUNC_NAME
static SCM
-scm_read_keyword (int chr, SCM port)
+scm_read_keyword (int chr, SCM port, scm_t_read_opts *opts)
{
SCM symbol;
@@ -982,7 +1083,7 @@ scm_read_keyword (int chr, SCM port)
to adapt to the delimiters currently valid of symbols.
XXX: This implementation allows sloppy syntaxes like `#: key'. */
- symbol = scm_read_expression (port);
+ symbol = scm_read_expression (port, opts);
if (!scm_is_symbol (symbol))
scm_i_input_error ("scm_read_keyword", port,
"keyword prefix `~a' not followed by a symbol: ~s",
@@ -992,34 +1093,186 @@ scm_read_keyword (int chr, SCM port)
}
static SCM
-scm_read_vector (int chr, SCM port, long line, int column)
+scm_read_vector (int chr, SCM port, scm_t_read_opts *opts,
+ long line, int column)
{
/* Note: We call `scm_read_sexp ()' rather than READER here in order to
guarantee that it's going to do what we want. After all, this is an
implementation detail of `scm_read_vector ()', not a desirable
property. */
- return maybe_annotate_source (scm_vector (scm_read_sexp (chr, port)),
- port, line, column);
+ return maybe_annotate_source (scm_vector (scm_read_sexp (chr, port, opts)),
+ port, opts, line, column);
+}
+
+/* Helper used by scm_read_array */
+static int
+read_decimal_integer (SCM port, int c, ssize_t *resp)
+{
+ ssize_t sign = 1;
+ ssize_t res = 0;
+ int got_it = 0;
+
+ if (c == '-')
+ {
+ sign = -1;
+ c = scm_getc_unlocked (port);
+ }
+
+ while ('0' <= c && c <= '9')
+ {
+ res = 10*res + c-'0';
+ got_it = 1;
+ c = scm_getc_unlocked (port);
+ }
+
+ if (got_it)
+ *resp = sign * res;
+ return c;
}
+/* Read an array. This function can also read vectors and uniform
+ vectors. Also, the conflict between '#f' and '#f32' and '#f64' is
+ handled here.
+
+ C is the first character read after the '#'. */
static SCM
-scm_read_array (int chr, SCM port, long line, int column)
+scm_read_array (int c, SCM port, scm_t_read_opts *opts, long line, int column)
{
- SCM result = scm_i_read_array (port, chr);
- if (scm_is_false (result))
- return result;
+ ssize_t rank;
+ scm_t_wchar tag_buf[8];
+ int tag_len;
+
+ SCM tag, shape = SCM_BOOL_F, elements, array;
+
+ /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but
+ the array code can not deal with zero-length dimensions yet, and
+ we want to allow zero-length vectors, of course. */
+ if (c == '(')
+ return scm_read_vector (c, port, opts, line, column);
+
+ /* Disambiguate between '#f' and uniform floating point vectors. */
+ if (c == 'f')
+ {
+ c = scm_getc_unlocked (port);
+ if (c != '3' && c != '6')
+ {
+ if (c != EOF)
+ scm_ungetc_unlocked (c, port);
+ return SCM_BOOL_F;
+ }
+ rank = 1;
+ tag_buf[0] = 'f';
+ tag_len = 1;
+ goto continue_reading_tag;
+ }
+
+ /* Read rank. */
+ rank = 1;
+ c = read_decimal_integer (port, c, &rank);
+ if (rank < 0)
+ scm_i_input_error (NULL, port, "array rank must be non-negative",
+ SCM_EOL);
+
+ /* Read tag. */
+ tag_len = 0;
+ continue_reading_tag:
+ while (c != EOF && c != '(' && c != '@' && c != ':'
+ && tag_len < sizeof tag_buf / sizeof tag_buf[0])
+ {
+ tag_buf[tag_len++] = c;
+ c = scm_getc_unlocked (port);
+ }
+ if (tag_len == 0)
+ tag = SCM_BOOL_T;
else
- return maybe_annotate_source (result, port, line, column);
+ {
+ tag = scm_string_to_symbol (scm_from_utf32_stringn (tag_buf, tag_len));
+ if (tag_len == sizeof tag_buf / sizeof tag_buf[0])
+ scm_i_input_error (NULL, port, "invalid array tag, starting with: ~a",
+ scm_list_1 (tag));
+ }
+
+ /* Read shape. */
+ if (c == '@' || c == ':')
+ {
+ shape = SCM_EOL;
+
+ do
+ {
+ ssize_t lbnd = 0, len = 0;
+ SCM s;
+
+ if (c == '@')
+ {
+ c = scm_getc_unlocked (port);
+ c = read_decimal_integer (port, c, &lbnd);
+ }
+
+ s = scm_from_ssize_t (lbnd);
+
+ if (c == ':')
+ {
+ c = scm_getc_unlocked (port);
+ c = read_decimal_integer (port, c, &len);
+ if (len < 0)
+ scm_i_input_error (NULL, port,
+ "array length must be non-negative",
+ SCM_EOL);
+
+ s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1));
+ }
+
+ shape = scm_cons (s, shape);
+ } while (c == '@' || c == ':');
+
+ shape = scm_reverse_x (shape, SCM_EOL);
+ }
+
+ /* Read nested lists of elements. */
+ if (c != '(')
+ scm_i_input_error (NULL, port,
+ "missing '(' in vector or array literal",
+ SCM_EOL);
+ elements = scm_read_sexp (c, port, opts);
+
+ if (scm_is_false (shape))
+ shape = scm_from_ssize_t (rank);
+ else if (scm_ilength (shape) != rank)
+ scm_i_input_error
+ (NULL, port,
+ "the number of shape specifications must match the array rank",
+ SCM_EOL);
+
+ /* Handle special print syntax of rank zero arrays; see
+ scm_i_print_array for a rationale. */
+ if (rank == 0)
+ {
+ if (!scm_is_pair (elements))
+ scm_i_input_error (NULL, port,
+ "too few elements in array literal, need 1",
+ SCM_EOL);
+ if (!scm_is_null (SCM_CDR (elements)))
+ scm_i_input_error (NULL, port,
+ "too many elements in array literal, want 1",
+ SCM_EOL);
+ elements = SCM_CAR (elements);
+ }
+
+ /* Construct array, annotate with source location, and return. */
+ array = scm_list_to_typed_array (tag, shape, elements);
+ return maybe_annotate_source (array, port, opts, line, column);
}
static SCM
-scm_read_srfi4_vector (int chr, SCM port, long line, int column)
+scm_read_srfi4_vector (int chr, SCM port, scm_t_read_opts *opts,
+ long line, int column)
{
- return scm_read_array (chr, port, line, column);
+ return scm_read_array (chr, port, opts, line, column);
}
static SCM
-scm_read_bytevector (scm_t_wchar chr, SCM port, long line, int column)
+scm_read_bytevector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts,
+ long line, int column)
{
chr = scm_getc_unlocked (port);
if (chr != 'u')
@@ -1034,8 +1287,8 @@ scm_read_bytevector (scm_t_wchar chr, SCM port, long
line, int column)
goto syntax;
return maybe_annotate_source
- (scm_u8_list_to_bytevector (scm_read_sexp (chr, port)),
- port, line, column);
+ (scm_u8_list_to_bytevector (scm_read_sexp (chr, port, opts)),
+ port, opts, line, column);
syntax:
scm_i_input_error ("read_bytevector", port,
@@ -1045,7 +1298,8 @@ scm_read_bytevector (scm_t_wchar chr, SCM port, long
line, int column)
}
static SCM
-scm_read_guile_bit_vector (scm_t_wchar chr, SCM port, long line, int column)
+scm_read_guile_bit_vector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts,
+ long line, int column)
{
/* Read the `#*10101'-style read syntax for bit vectors in Guile. This is
terribly inefficient but who cares? */
@@ -1063,7 +1317,7 @@ scm_read_guile_bit_vector (scm_t_wchar chr, SCM port,
long line, int column)
return maybe_annotate_source
(scm_bitvector (scm_reverse_x (s_bits, SCM_EOL)),
- port, line, column);
+ port, opts, line, column);
}
static SCM
@@ -1090,38 +1344,59 @@ scm_read_scsh_block_comment (scm_t_wchar chr, SCM port)
return SCM_UNSPECIFIED;
}
+static void set_port_case_insensitive_p (SCM port, scm_t_read_opts *opts,
+ int value);
+static void set_port_square_brackets_p (SCM port, scm_t_read_opts *opts,
+ int value);
+static void set_port_curly_infix_p (SCM port, scm_t_read_opts *opts,
+ int value);
+
static SCM
-scm_read_shebang (scm_t_wchar chr, SCM port)
+scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
{
- int c = 0;
- if ((c = scm_get_byte_or_eof_unlocked (port)) != 'r')
- {
- scm_ungetc_unlocked (c, port);
- return scm_read_scsh_block_comment (chr, port);
- }
- if ((c = scm_get_byte_or_eof_unlocked (port)) != '6')
- {
- scm_ungetc_unlocked (c, port);
- scm_ungetc_unlocked ('r', port);
- return scm_read_scsh_block_comment (chr, port);
- }
- if ((c = scm_get_byte_or_eof_unlocked (port)) != 'r')
- {
- scm_ungetc_unlocked (c, port);
- scm_ungetc_unlocked ('6', port);
- scm_ungetc_unlocked ('r', port);
- return scm_read_scsh_block_comment (chr, port);
- }
- if ((c = scm_get_byte_or_eof_unlocked (port)) != 's')
+ char name[READER_DIRECTIVE_NAME_MAX_SIZE + 1];
+ int c;
+ int i = 0;
+
+ while (i <= READER_DIRECTIVE_NAME_MAX_SIZE)
{
- scm_ungetc_unlocked (c, port);
- scm_ungetc_unlocked ('r', port);
- scm_ungetc_unlocked ('6', port);
- scm_ungetc_unlocked ('r', port);
- return scm_read_scsh_block_comment (chr, port);
+ c = scm_getc_unlocked (port);
+ if (c == EOF)
+ scm_i_input_error ("skip_block_comment", port,
+ "unterminated `#! ... !#' comment", SCM_EOL);
+ else if (('a' <= c && c <= 'z') || ('0' <= c && c <= '9') || c == '-')
+ name[i++] = c;
+ else if (CHAR_IS_DELIMITER (c))
+ {
+ scm_ungetc_unlocked (c, port);
+ name[i] = '\0';
+ if (0 == strcmp ("r6rs", name))
+ ; /* Silently ignore */
+ else if (0 == strcmp ("fold-case", name))
+ set_port_case_insensitive_p (port, opts, 1);
+ else if (0 == strcmp ("no-fold-case", name))
+ set_port_case_insensitive_p (port, opts, 0);
+ else if (0 == strcmp ("curly-infix", name))
+ set_port_curly_infix_p (port, opts, 1);
+ else if (0 == strcmp ("curly-infix-and-bracket-lists", name))
+ {
+ set_port_curly_infix_p (port, opts, 1);
+ set_port_square_brackets_p (port, opts, 0);
+ }
+ else
+ break;
+
+ return SCM_UNSPECIFIED;
+ }
+ else
+ {
+ scm_ungetc_unlocked (c, port);
+ break;
+ }
}
-
- return SCM_UNSPECIFIED;
+ while (i > 0)
+ scm_ungetc_unlocked (name[--i], port);
+ return scm_read_scsh_block_comment (chr, port);
}
static SCM
@@ -1163,16 +1438,17 @@ scm_read_r6rs_block_comment (scm_t_wchar chr, SCM port)
}
static SCM
-scm_read_commented_expression (scm_t_wchar chr, SCM port)
+scm_read_commented_expression (scm_t_wchar chr, SCM port,
+ scm_t_read_opts *opts)
{
scm_t_wchar c;
- c = flush_ws (port, (char *) NULL);
+ c = flush_ws (port, opts, (char *) NULL);
if (EOF == c)
scm_i_input_error ("read_commented_expression", port,
"no expression after #; comment", SCM_EOL);
scm_ungetc_unlocked (c, port);
- scm_read_expression (port);
+ scm_read_expression (port, opts);
return SCM_UNSPECIFIED;
}
@@ -1274,7 +1550,7 @@ scm_read_extended_symbol (scm_t_wchar chr, SCM port)
/* Top-level token readers, i.e., dispatchers. */
static SCM
-scm_read_sharp_extension (int chr, SCM port)
+scm_read_sharp_extension (int chr, SCM port, scm_t_read_opts *opts)
{
SCM proc;
@@ -1287,7 +1563,8 @@ scm_read_sharp_extension (int chr, SCM port)
got = scm_call_2 (proc, SCM_MAKE_CHAR (chr), port);
- if (scm_is_pair (got) && !scm_i_has_source_properties (got))
+ if (opts->record_positions_p && SCM_NIMP (got)
+ && !scm_i_has_source_properties (got))
scm_i_set_source_properties_x (got, line, column, SCM_FILENAME (port));
return got;
@@ -1299,43 +1576,44 @@ scm_read_sharp_extension (int chr, SCM port)
/* The reader for the sharp `#' character. It basically dispatches reads
among the above token readers. */
static SCM
-scm_read_sharp (scm_t_wchar chr, SCM port, long line, int column)
+scm_read_sharp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts,
+ long line, int column)
#define FUNC_NAME "scm_lreadr"
{
SCM result;
chr = scm_getc_unlocked (port);
- result = scm_read_sharp_extension (chr, port);
+ result = scm_read_sharp_extension (chr, port, opts);
if (!scm_is_eq (result, SCM_UNSPECIFIED))
return result;
switch (chr)
{
case '\\':
- return (scm_read_character (chr, port));
+ return (scm_read_character (chr, port, opts));
case '(':
- return (scm_read_vector (chr, port, line, column));
+ return (scm_read_vector (chr, port, opts, line, column));
case 's':
case 'u':
case 'f':
case 'c':
/* This one may return either a boolean or an SRFI-4 vector. */
- return (scm_read_srfi4_vector (chr, port, line, column));
+ return (scm_read_srfi4_vector (chr, port, opts, line, column));
case 'v':
- return (scm_read_bytevector (chr, port, line, column));
+ return (scm_read_bytevector (chr, port, opts, line, column));
case '*':
- return (scm_read_guile_bit_vector (chr, port, line, column));
+ return (scm_read_guile_bit_vector (chr, port, opts, line, column));
case 't':
case 'T':
case 'F':
return (scm_read_boolean (chr, port));
case ':':
- return (scm_read_keyword (chr, port));
+ return (scm_read_keyword (chr, port, opts));
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
case '@':
- return (scm_read_array (chr, port, line, column));
+ return (scm_read_array (chr, port, opts, line, column));
case 'i':
case 'e':
@@ -1349,21 +1627,21 @@ scm_read_sharp (scm_t_wchar chr, SCM port, long line,
int column)
case 'X':
case 'I':
case 'E':
- return (scm_read_number_and_radix (chr, port));
+ return (scm_read_number_and_radix (chr, port, opts));
case '{':
return (scm_read_extended_symbol (chr, port));
case '!':
- return (scm_read_shebang (chr, port));
+ return (scm_read_shebang (chr, port, opts));
case ';':
- return (scm_read_commented_expression (chr, port));
+ return (scm_read_commented_expression (chr, port, opts));
case '`':
case '\'':
case ',':
- return (scm_read_syntax (chr, port));
+ return (scm_read_syntax (chr, port, opts));
case 'n':
- return (scm_read_nil (chr, port));
+ return (scm_read_nil (chr, port, opts));
default:
- result = scm_read_sharp_extension (chr, port);
+ result = scm_read_sharp_extension (chr, port, opts);
if (scm_is_eq (result, SCM_UNSPECIFIED))
{
/* To remain compatible with 1.8 and earlier, the following
@@ -1387,8 +1665,8 @@ scm_read_sharp (scm_t_wchar chr, SCM port, long line, int
column)
#undef FUNC_NAME
static SCM
-scm_read_expression (SCM port)
-#define FUNC_NAME "scm_read_expression"
+read_inner_expression (SCM port, scm_t_read_opts *opts)
+#define FUNC_NAME "read_inner_expression"
{
while (1)
{
@@ -1404,23 +1682,55 @@ scm_read_expression (SCM port)
case ';':
(void) scm_read_semicolon_comment (chr, port);
break;
+ case '{':
+ if (opts->curly_infix_p)
+ {
+ if (opts->neoteric_p)
+ return scm_read_sexp (chr, port, opts);
+ else
+ {
+ SCM expr;
+
+ /* Enable neoteric expressions within curly braces */
+ opts->neoteric_p = 1;
+ expr = scm_read_sexp (chr, port, opts);
+ opts->neoteric_p = 0;
+ return expr;
+ }
+ }
+ else
+ return scm_read_mixed_case_symbol (chr, port, opts);
case '[':
- if (!SCM_SQUARE_BRACKETS_P)
- return (scm_read_mixed_case_symbol (chr, port));
- /* otherwise fall through */
+ if (opts->square_brackets_p)
+ return scm_read_sexp (chr, port, opts);
+ else if (opts->curly_infix_p)
+ {
+ /* The syntax of neoteric expressions requires that '[' be
+ a delimiter when curly-infix is enabled, so it cannot
+ be part of an unescaped symbol. We might as well do
+ something useful with it, so we adopt Kawa's convention:
+ [...] => ($bracket-list$ ...) */
+ long line = SCM_LINUM (port);
+ int column = SCM_COL (port) - 1;
+ return maybe_annotate_source
+ (scm_cons (sym_bracket_list, scm_read_sexp (chr, port, opts)),
+ port, opts, line, column);
+ }
+ else
+ return scm_read_mixed_case_symbol (chr, port, opts);
case '(':
- return (scm_read_sexp (chr, port));
+ return (scm_read_sexp (chr, port, opts));
case '"':
- return (scm_read_string (chr, port));
+ return (scm_read_string (chr, port, opts));
case '\'':
case '`':
case ',':
- return (scm_read_quote (chr, port));
+ return (scm_read_quote (chr, port, opts));
case '#':
{
long line = SCM_LINUM (port);
int column = SCM_COL (port) - 1;
- SCM result = scm_read_sharp (chr, port, line, column);
+ SCM result = scm_read_sharp (chr, port, opts, line, column);
if (scm_is_eq (result, SCM_UNSPECIFIED))
/* We read a comment or some such. */
break;
@@ -1430,33 +1740,108 @@ scm_read_expression (SCM port)
case ')':
scm_i_input_error (FUNC_NAME, port, "unexpected \")\"", SCM_EOL);
break;
+ case '}':
+ if (opts->curly_infix_p)
+ scm_i_input_error (FUNC_NAME, port, "unexpected \"}\"", SCM_EOL);
+ else
+ return scm_read_mixed_case_symbol (chr, port, opts);
case ']':
- if (SCM_SQUARE_BRACKETS_P)
+ if (opts->square_brackets_p)
scm_i_input_error (FUNC_NAME, port, "unexpected \"]\"", SCM_EOL);
/* otherwise fall through */
case EOF:
return SCM_EOF_VAL;
case ':':
- if (scm_is_eq (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_prefix))
- return scm_symbol_to_keyword (scm_read_expression (port));
+ if (opts->keyword_style == KEYWORD_STYLE_PREFIX)
+ return scm_symbol_to_keyword (scm_read_expression (port, opts));
/* Fall through. */
default:
{
if (((chr >= '0') && (chr <= '9'))
|| (strchr ("+-.", chr)))
- return (scm_read_number (chr, port));
+ return (scm_read_number (chr, port, opts));
else
- return (scm_read_mixed_case_symbol (chr, port));
+ return (scm_read_mixed_case_symbol (chr, port, opts));
}
}
}
}
#undef FUNC_NAME
+static SCM
+scm_read_expression (SCM port, scm_t_read_opts *opts)
+#define FUNC_NAME "scm_read_expression"
+{
+ if (!opts->neoteric_p)
+ return read_inner_expression (port, opts);
+ else
+ {
+ long line = 0;
+ int column = 0;
+ SCM expr;
+
+ if (opts->record_positions_p)
+ {
+ /* We need to get the position of the first non-whitespace
+ character in order to correctly annotate neoteric
+ expressions. For example, for the expression 'f(x)', the
+ first call to 'read_inner_expression' reads the 'f' (which
+ cannot be annotated), and then we later read the '(x)' and
+ use it to construct the new list (f x). */
+ int c = flush_ws (port, opts, (char *) NULL);
+ if (c == EOF)
+ return SCM_EOF_VAL;
+ scm_ungetc_unlocked (c, port);
+ line = SCM_LINUM (port);
+ column = SCM_COL (port);
+ }
+
+ expr = read_inner_expression (port, opts);
+
+ /* 'expr' is the first component of the neoteric expression. Now
+ we loop, and as long as the next character is '(', '[', or '{',
+ (without any intervening whitespace), we use it to construct a
+ new expression. For example, f{n - 1}(x) => ((f (- n 1)) x). */
+ for (;;)
+ {
+ int chr = scm_getc_unlocked (port);
+
+ if (chr == '(')
+ /* e(...) => (e ...) */
+ expr = scm_cons (expr, scm_read_sexp (chr, port, opts));
+ else if (chr == '[')
+ /* e[...] => ($bracket-apply$ e ...) */
+ expr = scm_cons (sym_bracket_apply,
+ scm_cons (expr,
+ scm_read_sexp (chr, port, opts)));
+ else if (chr == '{')
+ {
+ SCM arg = scm_read_sexp (chr, port, opts);
+
+ if (scm_is_null (arg))
+ expr = scm_list_1 (expr); /* e{} => (e) */
+ else
+ expr = scm_list_2 (expr, arg); /* e{...} => (e {...}) */
+ }
+ else
+ {
+ if (chr != EOF)
+ scm_ungetc_unlocked (chr, port);
+ break;
+ }
+ maybe_annotate_source (expr, port, opts, line, column);
+ }
+ return expr;
+ }
+}
+#undef FUNC_NAME
+
/* Actual reader. */
+static void init_read_options (SCM port, scm_t_read_opts *opts);
+
SCM_DEFINE (scm_read, "read", 0, 1, 0,
(SCM port),
"Read an s-expression from the input port @var{port}, or from\n"
@@ -1464,18 +1849,21 @@ SCM_DEFINE (scm_read, "read", 0, 1, 0,
"Any whitespace before the next token is discarded.")
#define FUNC_NAME s_scm_read
{
+ scm_t_read_opts opts;
int c;
if (SCM_UNBNDP (port))
port = scm_current_input_port ();
SCM_VALIDATE_OPINPORT (1, port);
- c = flush_ws (port, (char *) NULL);
+ init_read_options (port, &opts);
+
+ c = flush_ws (port, &opts, (char *) NULL);
if (EOF == c)
return SCM_EOF_VAL;
scm_ungetc_unlocked (c, port);
- return (scm_read_expression (port));
+ return (scm_read_expression (port, &opts));
}
#undef FUNC_NAME
@@ -1732,6 +2120,143 @@ SCM_DEFINE (scm_file_encoding, "file-encoding", 1, 0, 0,
}
#undef FUNC_NAME
+
+/* 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.
+
+ If a bit field contains READ_OPTION_INHERIT (3), that indicates that
+ the applicable value should be inherited from the corresponding
+ global read option. Otherwise, the bit field contains the value of
+ the read option. For boolean read options that have been set
+ per-port, the possible values are 0 or 1. If the 'keyword_style'
+ read option has been set per-port, its possible values are those in
+ 'enum t_keyword_style'. */
+
+/* Key to read options in per-port alists. */
+SCM_SYMBOL (sym_port_read_options, "port-read-options");
+
+/* Offsets of bit fields for each per-port override */
+#define READ_OPTION_COPY_SOURCE_P 0
+#define READ_OPTION_RECORD_POSITIONS_P 2
+#define READ_OPTION_CASE_INSENSITIVE_P 4
+#define READ_OPTION_KEYWORD_STYLE 6
+#define READ_OPTION_R6RS_ESCAPES_P 8
+#define READ_OPTION_SQUARE_BRACKETS_P 10
+#define READ_OPTION_HUNGRY_EOL_ESCAPES_P 12
+#define READ_OPTION_CURLY_INFIX_P 14
+
+/* The total width in bits of the per-port overrides */
+#define READ_OPTIONS_NUM_BITS 16
+
+#define READ_OPTIONS_INHERIT_ALL ((1UL << READ_OPTIONS_NUM_BITS) - 1)
+#define READ_OPTIONS_MAX_VALUE READ_OPTIONS_INHERIT_ALL
+
+#define READ_OPTION_MASK 3
+#define READ_OPTION_INHERIT 3
+
+static void
+set_port_read_option (SCM port, int option, int new_value)
+{
+ SCM 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);
+ if (scm_is_unsigned_integer (scm_read_options, 0, READ_OPTIONS_MAX_VALUE))
+ read_options = scm_to_uint (scm_read_options);
+ else
+ read_options = READ_OPTIONS_INHERIT_ALL;
+ 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);
+}
+
+/* Set OPTS and PORT's case-insensitivity according to VALUE. */
+static void
+set_port_case_insensitive_p (SCM port, scm_t_read_opts *opts, int value)
+{
+ value = !!value;
+ opts->case_insensitive_p = value;
+ set_port_read_option (port, READ_OPTION_CASE_INSENSITIVE_P, value);
+}
+
+/* Set OPTS and PORT's square_brackets_p option according to VALUE. */
+static void
+set_port_square_brackets_p (SCM port, scm_t_read_opts *opts, int value)
+{
+ value = !!value;
+ opts->square_brackets_p = value;
+ set_port_read_option (port, READ_OPTION_SQUARE_BRACKETS_P, value);
+}
+
+/* Set OPTS and PORT's curly_infix_p option according to VALUE. */
+static void
+set_port_curly_infix_p (SCM port, scm_t_read_opts *opts, int value)
+{
+ value = !!value;
+ opts->curly_infix_p = value;
+ set_port_read_option (port, READ_OPTION_CURLY_INFIX_P, value);
+}
+
+/* Initialize OPTS based on PORT's read options and the global read
+ options. */
+static void
+init_read_options (SCM port, scm_t_read_opts *opts)
+{
+ SCM val, scm_read_options;
+ unsigned int read_options, x;
+
+ scm_read_options = scm_assq_ref (SCM_PTAB_ENTRY(port)->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
+ read_options = READ_OPTIONS_INHERIT_ALL;
+
+ x = READ_OPTION_MASK & (read_options >> READ_OPTION_KEYWORD_STYLE);
+ if (x == READ_OPTION_INHERIT)
+ {
+ val = SCM_PACK (SCM_KEYWORD_STYLE);
+ if (scm_is_eq (val, scm_keyword_prefix))
+ x = KEYWORD_STYLE_PREFIX;
+ else if (scm_is_eq (val, scm_keyword_postfix))
+ x = KEYWORD_STYLE_POSTFIX;
+ else
+ x = KEYWORD_STYLE_HASH_PREFIX;
+ }
+ opts->keyword_style = x;
+
+#define RESOLVE_BOOLEAN_OPTION(NAME, name) \
+ do \
+ { \
+ x = READ_OPTION_MASK & (read_options >> READ_OPTION_ ## NAME); \
+ if (x == READ_OPTION_INHERIT) \
+ x = !!SCM_ ## NAME; \
+ opts->name = x; \
+ } \
+ while (0)
+
+ RESOLVE_BOOLEAN_OPTION (COPY_SOURCE_P, copy_source_p);
+ RESOLVE_BOOLEAN_OPTION (RECORD_POSITIONS_P, record_positions_p);
+ RESOLVE_BOOLEAN_OPTION (CASE_INSENSITIVE_P, case_insensitive_p);
+ RESOLVE_BOOLEAN_OPTION (R6RS_ESCAPES_P, r6rs_escapes_p);
+ RESOLVE_BOOLEAN_OPTION (SQUARE_BRACKETS_P, square_brackets_p);
+ RESOLVE_BOOLEAN_OPTION (HUNGRY_EOL_ESCAPES_P, hungry_eol_escapes_p);
+ RESOLVE_BOOLEAN_OPTION (CURLY_INFIX_P, curly_infix_p);
+
+#undef RESOLVE_BOOLEAN_OPTION
+
+ opts->neoteric_p = 0;
+}
+
void
scm_init_read ()
{
diff --git a/libguile/read.h b/libguile/read.h
index 4bd08fa..3c47afd 100644
--- a/libguile/read.h
+++ b/libguile/read.h
@@ -54,7 +54,6 @@ SCM_API SCM scm_sym_dot;
SCM_API SCM scm_read_options (SCM setting);
SCM_API SCM scm_read (SCM port);
-SCM_API size_t scm_read_token (int ic, SCM * tok_buf, SCM port, int weird);
SCM_API SCM scm_read_hash_extend (SCM chr, SCM proc);
SCM_INTERNAL char *scm_i_scan_for_encoding (SCM port);
SCM_API SCM scm_file_encoding (SCM port);
diff --git a/libguile/srfi-13.c b/libguile/srfi-13.c
index 2834553..97c5a1d 100644
--- a/libguile/srfi-13.c
+++ b/libguile/srfi-13.c
@@ -2993,11 +2993,22 @@ SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1,
3, 0,
#undef FUNC_NAME
SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0,
- (SCM str, SCM chr),
+ (SCM str, SCM char_pred),
"Split the string @var{str} into a list of the substrings
delimited\n"
- "by appearances of the character @var{chr}. Note that an empty
substring\n"
- "between separator characters will result in an empty string in
the\n"
- "result list.\n"
+ "by appearances of characters that\n"
+ "\n"
+ "@itemize @bullet\n"
+ "@item\n"
+ "equal @var{char_pred}, if it is a character,\n"
+ "\n"
+ "@item\n"
+ "satisfy the predicate @var{char_pred}, if it is a procedure,\n"
+ "\n"
+ "@item\n"
+ "are in the set @var{char_pred}, if it is a character set.\n"
+ "@end itemize\n\n"
+ "Note that an empty substring between separator characters\n"
+ "will result in an empty string in the result list.\n"
"\n"
"@lisp\n"
"(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n"
@@ -3014,47 +3025,73 @@ SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0,
"@end lisp")
#define FUNC_NAME s_scm_string_split
{
- long idx, last_idx;
- int narrow;
SCM res = SCM_EOL;
SCM_VALIDATE_STRING (1, str);
- SCM_VALIDATE_CHAR (2, chr);
- /* This is explicit wide/narrow logic (instead of using
- scm_i_string_ref) is a speed optimization. */
- idx = scm_i_string_length (str);
- narrow = scm_i_is_narrow_string (str);
- if (narrow)
+ if (SCM_CHARP (char_pred))
{
- const char *buf = scm_i_string_chars (str);
- while (idx >= 0)
+ long idx, last_idx;
+ int narrow;
+
+ /* This is explicit wide/narrow logic (instead of using
+ scm_i_string_ref) is a speed optimization. */
+ idx = scm_i_string_length (str);
+ narrow = scm_i_is_narrow_string (str);
+ if (narrow)
+ {
+ const char *buf = scm_i_string_chars (str);
+ while (idx >= 0)
+ {
+ last_idx = idx;
+ while (idx > 0 && buf[idx-1] != (char) SCM_CHAR(char_pred))
+ idx--;
+ if (idx >= 0)
+ {
+ res = scm_cons (scm_i_substring (str, idx, last_idx), res);
+ idx--;
+ }
+ }
+ }
+ else
{
- last_idx = idx;
- while (idx > 0 && buf[idx-1] != (char) SCM_CHAR(chr))
- idx--;
- if (idx >= 0)
+ const scm_t_wchar *buf = scm_i_string_wide_chars (str);
+ while (idx >= 0)
{
- res = scm_cons (scm_i_substring (str, idx, last_idx), res);
- idx--;
+ last_idx = idx;
+ while (idx > 0 && buf[idx-1] != SCM_CHAR(char_pred))
+ idx--;
+ if (idx >= 0)
+ {
+ res = scm_cons (scm_i_substring (str, idx, last_idx), res);
+ idx--;
+ }
}
}
}
else
{
- const scm_t_wchar *buf = scm_i_string_wide_chars (str);
- while (idx >= 0)
+ SCM sidx, slast_idx;
+
+ if (!SCM_CHARSETP (char_pred))
+ SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)),
+ char_pred, SCM_ARG2, FUNC_NAME);
+
+ /* Supporting predicates and character sets involves handling SCM
+ values so there is less chance to optimize. */
+ slast_idx = scm_string_length (str);
+ for (;;)
{
- last_idx = idx;
- while (idx > 0 && buf[idx-1] != SCM_CHAR(chr))
- idx--;
- if (idx >= 0)
- {
- res = scm_cons (scm_i_substring (str, idx, last_idx), res);
- idx--;
- }
+ sidx = scm_string_index_right (str, char_pred, SCM_INUM0, slast_idx);
+ if (scm_is_false (sidx))
+ break;
+ res = scm_cons (scm_substring (str, scm_oneplus (sidx), slast_idx),
res);
+ slast_idx = sidx;
}
+
+ res = scm_cons (scm_substring (str, SCM_INUM0, slast_idx), res);
}
+
scm_remember_upto_here_1 (str);
return res;
}
diff --git a/libguile/srfi-13.h b/libguile/srfi-13.h
index f63239a..325e222 100644
--- a/libguile/srfi-13.h
+++ b/libguile/srfi-13.h
@@ -110,7 +110,7 @@ SCM_API SCM scm_xsubstring (SCM s, SCM from, SCM to, SCM
start, SCM end);
SCM_API SCM scm_string_xcopy_x (SCM target, SCM tstart, SCM s, SCM sfrom, SCM
sto, SCM start, SCM end);
SCM_API SCM scm_string_replace (SCM s1, SCM s2, SCM start1, SCM end1, SCM
start2, SCM end2);
SCM_API SCM scm_string_tokenize (SCM s, SCM token_char, SCM start, SCM end);
-SCM_API SCM scm_string_split (SCM s, SCM chr);
+SCM_API SCM scm_string_split (SCM s, SCM char_pred);
SCM_API SCM scm_string_filter (SCM char_pred, SCM s, SCM start, SCM end);
SCM_API SCM scm_string_delete (SCM char_pred, SCM s, SCM start, SCM end);
diff --git a/libguile/strings.c b/libguile/strings.c
index 7c5550f..5130cb3 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -1997,7 +1997,10 @@ u32_u8_length_in_bytes (const scm_t_uint32 *str, size_t
len)
char *
scm_to_utf8_stringn (SCM str, size_t *lenp)
+#define FUNC_NAME "scm_to_utf8_stringn"
{
+ SCM_VALIDATE_STRING (1, str);
+
if (scm_i_is_narrow_string (str))
return (char *) latin1_to_u8 ((scm_t_uint8 *) scm_i_string_chars (str),
scm_i_string_length (str),
@@ -2044,6 +2047,7 @@ scm_to_utf8_stringn (SCM str, size_t *lenp)
}
}
}
+#undef FUNC_NAME
scm_t_wchar *
scm_to_utf32_string (SCM str)
diff --git a/meta/Makefile.am b/meta/Makefile.am
index acf8854..c9d6a3f 100644
--- a/meta/Makefile.am
+++ b/meta/Makefile.am
@@ -28,7 +28,7 @@ EXTRA_DIST= \
guild.in guile-config.in
# What we now call `guild' used to be known as `guile-tools'.
-install-data-hook:
+install-exec-hook:
guild="`echo $(ECHO_N) guild \
| $(SED) -e '$(program_transform_name)'`$(EXEEXT)" ; \
guile_tools="`echo $(ECHO_N) guile-tools \
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 14dfb60..1285c83 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -3137,8 +3137,11 @@ module '(ice-9 q) '(make-q q-length))}."
(lambda (option)
(apply (lambda (name value documentation)
(display name)
- (if (< (string-length (symbol->string name)) 8)
- (display #\tab))
+ (let ((len (string-length (symbol->string name))))
+ (when (< len 16)
+ (display #\tab)
+ (when (< len 8)
+ (display #\tab))))
(display #\tab)
(display value)
(display #\tab)
@@ -3509,7 +3512,9 @@ module '(ice-9 q) '(make-q q-length))}."
(define-syntax define-public
(syntax-rules ()
((_ (name . args) . body)
- (define-public name (lambda args . body)))
+ (begin
+ (define name (lambda args . body))
+ (export name)))
((_ name val)
(begin
(define name val)
@@ -3899,7 +3904,7 @@ module '(ice-9 q) '(make-q q-length))}."
;;;
;;; Currently, the following feature identifiers are supported:
;;;
-;;; guile r5rs srfi-0 srfi-4 srfi-6 srfi-13 srfi-14 srfi-55 srfi-61
+;;; guile r5rs srfi-0 srfi-4 srfi-6 srfi-13 srfi-14 srfi-55 srfi-61 srfi-105
;;;
;;; Remember to update the features list when adding more SRFIs.
;;;
@@ -3919,6 +3924,7 @@ module '(ice-9 q) '(make-q q-length))}."
srfi-39 ;; parameterize
srfi-55 ;; require-extension
srfi-61 ;; general cond clause
+ srfi-105 ;; curly infix expressions
))
;; This table maps module public interfaces to the list of features.
diff --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm
index 62a2c9e..d60a6e3 100644
--- a/module/ice-9/command-line.scm
+++ b/module/ice-9/command-line.scm
@@ -1,6 +1,6 @@
;;; Parsing Guile's command-line
-;;; Copyright (C) 1994-1998, 2000-2011 Free Software Foundation, Inc.
+;;; Copyright (C) 1994-1998, 2000-2011, 2012 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
@@ -325,7 +325,7 @@ If FILE begins with `-' the -s switch is mandatory.
((string=? arg "--listen") ; start a repl server
(parse args
- (cons '(@@ (system repl server) (spawn-server)) out)))
+ (cons '((@@ (system repl server) spawn-server)) out)))
((string-prefix? "--listen=" arg) ; start a repl server
(parse
@@ -336,14 +336,12 @@ If FILE begins with `-' the -s switch is mandatory.
((string->number where) ; --listen=PORT
=> (lambda (port)
(if (and (integer? port) (exact? port) (>= port 0))
- `(@@ (system repl server)
- (spawn-server
- (make-tcp-server-socket #:port ,port)))
+ `((@@ (system repl server) spawn-server)
+ ((@@ (system repl server) make-tcp-server-socket)
#:port ,port))
(error "invalid port for --listen"))))
((string-prefix? "/" where) ; --listen=/PATH/TO/SOCKET
- `(@@ (system repl server)
- (spawn-server
- (make-unix-domain-server-socket #:path ,where))))
+ `((@@ (system repl server) spawn-server)
+ ((@@ (system repl server) make-unix-domain-server-socket)
#:path ,where)))
(else
(error "unknown argument to --listen"))))
out)))
diff --git a/module/ice-9/curried-definitions.scm
b/module/ice-9/curried-definitions.scm
index d55f1fb..8c684a1 100644
--- a/module/ice-9/curried-definitions.scm
+++ b/module/ice-9/curried-definitions.scm
@@ -16,7 +16,8 @@
(define-module (ice-9 curried-definitions)
#:replace ((cdefine . define)
- (cdefine* . define*)))
+ (cdefine* . define*)
+ define-public))
(define-syntax cdefine
(syntax-rules ()
@@ -39,3 +40,14 @@
(lambda* rest body body* ...)))
((_ . rest)
(define* . rest))))
+
+(define-syntax define-public
+ (syntax-rules ()
+ ((_ (name . args) . body)
+ (begin
+ (cdefine (name . args) . body)
+ (export name)))
+ ((_ name val)
+ (begin
+ (define name val)
+ (export name)))))
diff --git a/module/ice-9/format.scm b/module/ice-9/format.scm
index d038ace..eed8cbb 100644
--- a/module/ice-9/format.scm
+++ b/module/ice-9/format.scm
@@ -427,15 +427,15 @@
(case modifier
((at)
(format:out-str
- (with-output-to-string
- (lambda ()
- (truncated-print (next-arg)
+ (call-with-output-string
+ (lambda (p)
+ (truncated-print (next-arg) p
#:width width)))))
((colon-at)
(format:out-str
- (with-output-to-string
- (lambda ()
- (truncated-print (next-arg)
+ (call-with-output-string
+ (lambda (p)
+ (truncated-print (next-arg) p
#:width
(max (- width
output-col)
@@ -779,7 +779,7 @@
(define (format:obj->str obj slashify)
(let ((res (if slashify
(object->string obj)
- (with-output-to-string (lambda () (display obj))))))
+ (call-with-output-string (lambda (p) (display obj p))))))
(if (and format:read-proof (string-prefix? "#<" res))
(object->string res)
res)))
diff --git a/module/ice-9/regex.scm b/module/ice-9/regex.scm
index f7b94b7..08ae2c2 100644
--- a/module/ice-9/regex.scm
+++ b/module/ice-9/regex.scm
@@ -172,8 +172,9 @@
(let loop ((start 0)
(value init)
(abuts #f)) ; True if start abuts a previous match.
+ (define bol (if (zero? start) 0 regexp/notbol))
(let ((m (if (> start (string-length string)) #f
- (regexp-exec regexp string start flags))))
+ (regexp-exec regexp string start (logior flags bol)))))
(cond
((not m) value)
((and (= (match:start m) (match:end m)) abuts)
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index 1812686..e3f6a90 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -516,6 +516,27 @@
(define-primitive-expander f64vector-set! (vec i x)
(bytevector-ieee-double-native-set! vec (* i 8) x))
+;; Appropriate for use with either 'eqv?' or 'equal?'.
+(define maybe-simplify-to-eq
+ (case-lambda
+ ((src a b)
+ ;; Simplify cases where either A or B is constant.
+ (define (maybe-simplify a b)
+ (and (const? a)
+ (let ((v (const-exp a)))
+ (and (or (memq v '(#f #t () #nil))
+ (symbol? v)
+ (and (integer? v)
+ (exact? v)
+ (<= v most-positive-fixnum)
+ (>= v most-negative-fixnum)))
+ (make-primcall src 'eq? (list a b))))))
+ (or (maybe-simplify a b) (maybe-simplify b a)))
+ (else #f)))
+
+(hashq-set! *primitive-expand-table* 'eqv? maybe-simplify-to-eq)
+(hashq-set! *primitive-expand-table* 'equal? maybe-simplify-to-eq)
+
(hashq-set! *primitive-expand-table*
'@dynamic-wind
(case-lambda
diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm
index d8f7643..c0a27b1 100644
--- a/module/srfi/srfi-19.scm
+++ b/module/srfi/srfi-19.scm
@@ -1113,13 +1113,13 @@
(cons #\1 (lambda (date pad-with port)
(display (date->string date "~Y-~m-~d") port)))
(cons #\2 (lambda (date pad-with port)
- (display (date->string date "~k:~M:~S~z") port)))
+ (display (date->string date "~H:~M:~S~z") port)))
(cons #\3 (lambda (date pad-with port)
- (display (date->string date "~k:~M:~S") port)))
+ (display (date->string date "~H:~M:~S") port)))
(cons #\4 (lambda (date pad-with port)
- (display (date->string date "~Y-~m-~dT~k:~M:~S~z") port)))
+ (display (date->string date "~Y-~m-~dT~H:~M:~S~z") port)))
(cons #\5 (lambda (date pad-with port)
- (display (date->string date "~Y-~m-~dT~k:~M:~S") port)))))
+ (display (date->string date "~Y-~m-~dT~H:~M:~S") port)))))
(define (get-formatter char)
diff --git a/module/srfi/srfi-31.scm b/module/srfi/srfi-31.scm
index 4238dc2..cf67e8a 100644
--- a/module/srfi/srfi-31.scm
+++ b/module/srfi/srfi-31.scm
@@ -1,6 +1,6 @@
;;; srfi-31.scm --- special form for recursive evaluation
-;; Copyright (C) 2004, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2004, 2006, 2012 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
@@ -19,17 +19,15 @@
;;; Original author: Rob Browning <address@hidden>
(define-module (srfi srfi-31)
- :export-syntax (rec))
+ #:export (rec))
-(define-macro (rec arg-form . body)
- (cond
- ((and (symbol? arg-form) (= 1 (length body)))
- ;; (rec S (cons 1 (delay S)))
- `(letrec ((,arg-form ,(car body)))
- ,arg-form))
- ;; (rec (f x) (+ x 1))
- ((list? arg-form)
- `(letrec ((,(car arg-form) (lambda ,(cdr arg-form) ,@body)))
- ,(car arg-form)))
- (else
- (error "syntax error in rec form" `(rec ,arg-form ,@body)))))
+(define-syntax rec
+ (syntax-rules ()
+ "Return the given object, defined in a lexical environment where
+NAME is bound to itself."
+ ((_ (name . formals) body ...) ; procedure
+ (letrec ((name (lambda formals body ...)))
+ name))
+ ((_ name expr) ; arbitrary object
+ (letrec ((name expr))
+ name))))
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 0bc11a3..afcb55a 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -1,6 +1,6 @@
;;; High-level compiler interface
-;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011, 2012 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
@@ -72,7 +72,7 @@
;; before the check, so that we avoid races (possibly due to parallel
;; compilation).
;;
-(define (ensure-writable-dir dir)
+(define (ensure-directory dir)
(catch 'system-error
(lambda ()
(mkdir dir))
@@ -80,13 +80,12 @@
(let ((errno (and (pair? rest) (car rest))))
(cond
((eqv? errno EEXIST)
- (let ((st (stat dir)))
- (if (or (not (eq? (stat:type st) 'directory))
- (not (access? dir W_OK)))
- (error "directory not writable" dir))))
+ ;; Assume it's a writable directory, to avoid TOCTOU errors,
+ ;; as well as UID/EUID mismatches that occur with access(2).
+ #t)
((eqv? errno ENOENT)
- (ensure-writable-dir (dirname dir))
- (ensure-writable-dir dir))
+ (ensure-directory (dirname dir))
+ (ensure-directory dir))
(else
(throw k subr fmt args rest)))))))
@@ -125,7 +124,7 @@
%compile-fallback-path
(canonical->suffix (canonicalize-path file))
(compiled-extension))))
- (and (false-if-exception (ensure-writable-dir (dirname f)))
+ (and (false-if-exception (ensure-directory (dirname f)))
f))))
(define* (compile-file file #:key
@@ -144,7 +143,7 @@
;; Choose the input encoding deterministically.
(set-port-encoding! in (or enc "UTF-8"))
- (ensure-writable-dir (dirname comp))
+ (ensure-directory (dirname comp))
(call-with-output-file/atomic comp
(lambda (port)
((language-printer (ensure-language to))
diff --git a/module/texinfo.scm b/module/texinfo.scm
index 2ffd853..519db48 100644
--- a/module/texinfo.scm
+++ b/module/texinfo.scm
@@ -384,8 +384,14 @@ Examples:
;; Like a DTD for texinfo
(define (command-spec command)
- (or (assq command texi-command-specs)
- (parser-error #f "Unknown command" command)))
+ (let ((spec (assq command texi-command-specs)))
+ (cond
+ ((not spec)
+ (parser-error #f "Unknown command" command))
+ ((eq? (cadr spec) 'ALIAS)
+ (command-spec (cddr spec)))
+ (else
+ spec))))
(define (inline-content? content)
(case content
@@ -647,11 +653,10 @@ Examples:
(arguments->attlist port (read-arguments port stop-char) arg-names))
(let* ((spec (command-spec command))
+ (command (car spec))
(type (cadr spec))
(arg-names (cddr spec)))
(case type
- ((ALIAS)
- (complete-start-command arg-names port))
((INLINE-TEXT)
(assert-curr-char '(#\{) "Inline element lacks {" port)
(values command '() type))
@@ -954,7 +959,9 @@ Examples:
(loop port expect-eof? end-para need-break? seed)))
((START) ; Start of an @-command
(let* ((head (token-head token))
- (type (cadr (command-spec head)))
+ (spec (command-spec head))
+ (head (car spec))
+ (type (cadr spec))
(inline? (inline-content? type))
(seed ((if (and inline? (not need-break?))
identity end-para) seed))
@@ -1045,8 +1052,9 @@ Examples:
(lambda (command args content seed) ; fdown
'())
(lambda (command args parent-seed seed) ; fup
- (let ((seed (reverse-collect-str-drop-ws seed))
- (spec (command-spec command)))
+ (let* ((seed (reverse-collect-str-drop-ws seed))
+ (spec (command-spec command))
+ (command (car spec)))
(if (eq? (cadr spec) 'INLINE-TEXT-ARGS)
(cons (list command (cons '% (parse-inline-text-args #f spec seed)))
parent-seed)
@@ -1062,8 +1070,10 @@ Examples:
(let ((parser (make-dom-parser)))
;; duplicate arguments->attlist to avoid unnecessary splitting
(lambda (command port)
- (let ((args (cdar (parser '*ENVIRON-ARGS* port '())))
- (arg-names (cddr (command-spec command))))
+ (let* ((args (cdar (parser '*ENVIRON-ARGS* port '())))
+ (spec (command-spec command))
+ (command (car spec))
+ (arg-names (cddr spec)))
(cond
((not arg-names)
(if (null? args) '()
diff --git a/module/web/client.scm b/module/web/client.scm
index b035668..cf7ea53 100644
--- a/module/web/client.scm
+++ b/module/web/client.scm
@@ -1,6 +1,6 @@
;;; Web client
-;; Copyright (C) 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2011, 2012 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
@@ -42,19 +42,37 @@
http-get))
(define (open-socket-for-uri uri)
- (let* ((ai (car (getaddrinfo (uri-host uri)
- (cond
- ((uri-port uri) => number->string)
- (else (symbol->string (uri-scheme uri)))))))
- (s (socket (addrinfo:fam ai) (addrinfo:socktype ai)
- (addrinfo:protocol ai))))
- (set-port-encoding! s "ISO-8859-1")
- (connect s (addrinfo:addr ai))
- ;; Buffer input and output on this port.
- (setvbuf s _IOFBF)
- ;; Enlarge the receive buffer.
- (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024))
- s))
+ "Return an open input/output port for a connection to URI."
+ (define addresses
+ (let ((port (uri-port uri)))
+ (getaddrinfo (uri-host uri)
+ (cond (port => number->string)
+ (else (symbol->string (uri-scheme uri))))
+ (if port
+ AI_NUMERICSERV
+ 0))))
+
+ (let loop ((addresses addresses))
+ (let* ((ai (car addresses))
+ (s (socket (addrinfo:fam ai) (addrinfo:socktype ai)
+ (addrinfo:protocol ai))))
+ (set-port-encoding! s "ISO-8859-1")
+
+ (catch 'system-error
+ (lambda ()
+ (connect s (addrinfo:addr ai))
+
+ ;; Buffer input and output on this port.
+ (setvbuf s _IOFBF)
+ ;; Enlarge the receive buffer.
+ (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024))
+ s)
+ (lambda args
+ ;; Connection failed, so try one of the other addresses.
+ (close s)
+ (if (null? addresses)
+ (apply throw args)
+ (loop (cdr addresses))))))))
(define (decode-string bv encoding)
(if (string-ci=? encoding "utf-8")
diff --git a/module/web/uri.scm b/module/web/uri.scm
index 109118b..78614a5 100644
--- a/module/web/uri.scm
+++ b/module/web/uri.scm
@@ -364,7 +364,9 @@ Percent-encoding first writes out the given character to a
bytevector
within the given @var{encoding}, then encodes each byte as
@address@hidden, where @var{HH} is the hexadecimal representation of
the byte."
- (if (string-index str unescaped-chars)
+ (define (needs-escaped? ch)
+ (not (char-set-contains? unescaped-chars ch)))
+ (if (string-index str needs-escaped?)
(call-with-output-string*
(lambda (port)
(string-for-each
@@ -377,6 +379,8 @@ the byte."
(if (< i len)
(let ((byte (bytevector-u8-ref bv i)))
(display #\% port)
+ (when (< byte 16)
+ (display #\0 port))
(display (number->string byte 16) port)
(lp (1+ i))))))))
str)))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index c20a977..2413259 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -136,6 +136,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-67.test \
tests/srfi-69.test \
tests/srfi-88.test \
+ tests/srfi-105.test \
tests/srfi-4.test \
tests/srfi-9.test \
tests/statprof.test \
diff --git a/test-suite/tests/chars.test b/test-suite/tests/chars.test
index bdc9bdb..98854f7 100644
--- a/test-suite/tests/chars.test
+++ b/test-suite/tests/chars.test
@@ -45,18 +45,18 @@
(pass-if "char=? #\\A #\\A"
(char=? #\A #\A))
- (expect-fail "char=? #\\A #\\a"
- (char=? #\A #\a))
+ (pass-if "char=? #\\A #\\a"
+ (not (char=? #\A #\a)))
- (expect-fail "char=? #\\A #\\B"
- (char=? #\A #\B))
+ (pass-if "char=? #\\A #\\B"
+ (not (char=? #\A #\B)))
- (expect-fail "char=? #\\B #\\A"
- (char=? #\A #\B))
+ (pass-if "char=? #\\B #\\A"
+ (not (char=? #\A #\B)))
;; char<?
- (expect-fail "char<? #\\A #\\A"
- (char<? #\A #\A))
+ (pass-if "char<? #\\A #\\A"
+ (not (char<? #\A #\A)))
(pass-if "char<? #\\A #\\a"
(char<? #\A #\a))
@@ -64,8 +64,8 @@
(pass-if "char<? #\\A #\\B"
(char<? #\A #\B))
- (expect-fail "char<? #\\B #\\A"
- (char<? #\B #\A))
+ (pass-if "char<? #\\B #\\A"
+ (not (char<? #\B #\A)))
;; char<=?
(pass-if "char<=? #\\A #\\A"
@@ -77,18 +77,18 @@
(pass-if "char<=? #\\A #\\B"
(char<=? #\A #\B))
- (expect-fail "char<=? #\\B #\\A"
- (char<=? #\B #\A))
+ (pass-if "char<=? #\\B #\\A"
+ (not (char<=? #\B #\A)))
;; char>?
- (expect-fail "char>? #\\A #\\A"
- (char>? #\A #\A))
+ (pass-if "char>? #\\A #\\A"
+ (not (char>? #\A #\A)))
- (expect-fail "char>? #\\A #\\a"
- (char>? #\A #\a))
+ (pass-if "char>? #\\A #\\a"
+ (not (char>? #\A #\a)))
- (expect-fail "char>? #\\A #\\B"
- (char>? #\A #\B))
+ (pass-if "char>? #\\A #\\B"
+ (not (char>? #\A #\B)))
(pass-if "char>? #\\B #\\A"
(char>? #\B #\A))
@@ -97,11 +97,11 @@
(pass-if "char>=? #\\A #\\A"
(char>=? #\A #\A))
- (expect-fail "char>=? #\\A #\\a"
- (char>=? #\A #\a))
+ (pass-if "char>=? #\\A #\\a"
+ (not (char>=? #\A #\a)))
- (expect-fail "char>=? #\\A #\\B"
- (char>=? #\A #\B))
+ (pass-if "char>=? #\\A #\\B"
+ (not (char>=? #\A #\B)))
(pass-if "char>=? #\\B #\\A"
(char>=? #\B #\A))
@@ -113,24 +113,24 @@
(pass-if "char-ci=? #\\A #\\a"
(char-ci=? #\A #\a))
- (expect-fail "char-ci=? #\\A #\\B"
- (char-ci=? #\A #\B))
+ (pass-if "char-ci=? #\\A #\\B"
+ (not (char-ci=? #\A #\B)))
- (expect-fail "char-ci=? #\\B #\\A"
- (char-ci=? #\A #\B))
+ (pass-if "char-ci=? #\\B #\\A"
+ (not (char-ci=? #\A #\B)))
;; char-ci<?
- (expect-fail "char-ci<? #\\A #\\A"
- (char-ci<? #\A #\A))
+ (pass-if "char-ci<? #\\A #\\A"
+ (not (char-ci<? #\A #\A)))
- (expect-fail "char-ci<? #\\A #\\a"
- (char-ci<? #\A #\a))
+ (pass-if "char-ci<? #\\A #\\a"
+ (not (char-ci<? #\A #\a)))
(pass-if "char-ci<? #\\A #\\B"
(char-ci<? #\A #\B))
- (expect-fail "char-ci<? #\\B #\\A"
- (char-ci<? #\B #\A))
+ (pass-if "char-ci<? #\\B #\\A"
+ (not (char-ci<? #\B #\A)))
;; char-ci<=?
(pass-if "char-ci<=? #\\A #\\A"
@@ -142,18 +142,18 @@
(pass-if "char-ci<=? #\\A #\\B"
(char-ci<=? #\A #\B))
- (expect-fail "char-ci<=? #\\B #\\A"
- (char-ci<=? #\B #\A))
+ (pass-if "char-ci<=? #\\B #\\A"
+ (not (char-ci<=? #\B #\A)))
;; char-ci>?
- (expect-fail "char-ci>? #\\A #\\A"
- (char-ci>? #\A #\A))
+ (pass-if "char-ci>? #\\A #\\A"
+ (not (char-ci>? #\A #\A)))
- (expect-fail "char-ci>? #\\A #\\a"
- (char-ci>? #\A #\a))
+ (pass-if "char-ci>? #\\A #\\a"
+ (not (char-ci>? #\A #\a)))
- (expect-fail "char-ci>? #\\A #\\B"
- (char-ci>? #\A #\B))
+ (pass-if "char-ci>? #\\A #\\B"
+ (not (char-ci>? #\A #\B)))
(pass-if "char-ci>? #\\B #\\A"
(char-ci>? #\B #\A))
@@ -165,8 +165,8 @@
(pass-if "char-ci>=? #\\A #\\a"
(char-ci>=? #\A #\a))
- (expect-fail "char-ci>=? #\\A #\\B"
- (char-ci>=? #\A #\B))
+ (pass-if "char-ci>=? #\\A #\\B"
+ (not (char-ci>=? #\A #\B)))
(pass-if "char-ci>=? #\\B #\\A"
(char-ci>=? #\B #\A)))
diff --git a/test-suite/tests/list.test b/test-suite/tests/list.test
index dc06f07..ff31c86 100644
--- a/test-suite/tests/list.test
+++ b/test-suite/tests/list.test
@@ -439,15 +439,15 @@
(with-test-prefix "wrong argument"
- (expect-fail-exception "improper list and empty list"
+ (pass-if-exception "improper list and empty list"
exception:wrong-type-arg
(append! (cons 1 2) '()))
- (expect-fail-exception "improper list and list"
+ (pass-if-exception "improper list and list"
exception:wrong-type-arg
(append! (cons 1 2) (list 3 4)))
- (expect-fail-exception "list, improper list and list"
+ (pass-if-exception "list, improper list and list"
exception:wrong-type-arg
(append! (list 1 2) (cons 3 4) (list 5 6)))
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index a6697c9..ddbd209 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -4845,7 +4845,7 @@
(test+/- n d))))))
(with-test-prefix "divide by zero"
- (for `((0 0.0 +0.0)) ;; denominators
+ (for `((0 0.0 -0.0)) ;; denominators
(lambda (d)
(for `((15 ,(* 3/2 big) 18.0 33/7
0 0.0 -0.0 +inf.0 -inf.0 +nan.0)) ;; numerators
diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test
index 60c853c..6e02255 100644
--- a/test-suite/tests/reader.test
+++ b/test-suite/tests/reader.test
@@ -401,6 +401,19 @@
(lambda ()
(read-disable 'hungry-eol-escapes))))))
+(with-test-prefix "per-port-read-options"
+ (pass-if "case-sensitive"
+ (equal? '(guile GuiLe gUIle)
+ (with-read-options '(case-insensitive)
+ (lambda ()
+ (with-input-from-string "GUIle #!no-fold-case GuiLe gUIle"
+ (lambda ()
+ (list (read) (read) (read))))))))
+ (pass-if "case-insensitive"
+ (equal? '(GUIle guile guile)
+ (with-input-from-string "GUIle #!fold-case GuiLe gUIle"
+ (lambda ()
+ (list (read) (read) (read)))))))
(with-test-prefix "#;"
(for-each
diff --git a/test-suite/tests/regexp.test b/test-suite/tests/regexp.test
index c2b65a6..eba4153 100644
--- a/test-suite/tests/regexp.test
+++ b/test-suite/tests/regexp.test
@@ -1,8 +1,9 @@
;;;; regexp.test --- test Guile's regexps -*- coding: utf-8; mode: scheme
-*-
;;;; Jim Blandy <address@hidden> --- September 1999
;;;;
-;;;; Copyright (C) 1999, 2004, 2006, 2007, 2008, 2009, 2010 Free Software
Foundation, Inc.
-;;;;
+;;;; Copyright (C) 1999, 2004, 2006, 2007, 2008, 2009, 2010,
+;;;; 2012 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
@@ -131,7 +132,14 @@
(lambda (match result)
(cons (match:substring match)
result))
- (logior regexp/notbol regexp/noteol)))))
+ (logior regexp/notbol regexp/noteol))))
+
+ (pass-if "regexp/notbol is set correctly"
+ (equal? '("foo")
+ (fold-matches "^foo" "foofoofoofoo" '()
+ (lambda (match result)
+ (cons (match:substring match)
+ result))))))
;;;
@@ -282,4 +290,12 @@
(with-locale "en_US.utf8"
;; bug #31650
(equal? (match:substring (string-match ".*" "calçot") 0)
- "calçot"))))
+ "calçot")))
+
+ (pass-if "match structures refer to char offsets, non-ASCII pattern"
+ (with-locale "en_US.utf8"
+ ;; bug #31650
+ (equal? (match:substring (string-match "λ: The Ultimate (.*)"
+ "λ: The Ultimate GOTO")
+ 1)
+ "GOTO"))))
diff --git a/test-suite/tests/srfi-105.test b/test-suite/tests/srfi-105.test
new file mode 100644
index 0000000..99a084b
--- /dev/null
+++ b/test-suite/tests/srfi-105.test
@@ -0,0 +1,240 @@
+;;;; srfi-105.test --- Test suite for Guile's SRFI-105 reader. -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2012 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
+
+(define-module (test-srfi-105)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-1))
+
+(define (read-string s)
+ (with-fluids ((%default-port-encoding #f))
+ (with-input-from-string s read)))
+
+(define (with-read-options opts thunk)
+ (let ((saved-options (read-options)))
+ (dynamic-wind
+ (lambda ()
+ (read-options opts))
+ thunk
+ (lambda ()
+ (read-options saved-options)))))
+
+;; Verify that curly braces are allowed in identifiers and that neoteric
+;; expressions are not recognized by default.
+(with-test-prefix "no-curly-infix"
+ (pass-if (equal? '({f(x) + g[y] + h{z} + [a]})
+ `(,(string->symbol "{f")
+ (x) + g [y] +
+ ,(string->symbol "h{z}")
+ + [a]
+ ,(string->symbol "}")))))
+
+#!curly-infix
+
+(with-test-prefix "curly-infix"
+ (pass-if (equal? '{n <= 5} '(<= n 5)))
+ (pass-if (equal? '{x + 1} '(+ x 1)))
+ (pass-if (equal? '{a + b + c} '(+ a b c)))
+ (pass-if (equal? '{x ,op y ,op z} '(,op x y z)))
+ (pass-if (equal? '{x eqv? `a} '(eqv? x `a)))
+ (pass-if (equal? '{'a eq? b} '(eq? 'a b)))
+ (pass-if (equal? '{n-1 + n-2} '(+ n-1 n-2)))
+ (pass-if (equal? '{a * {b + c}} '(* a (+ b c))))
+ (pass-if (equal? '{a + {b - c}} '(+ a (- b c))))
+ (pass-if (equal? '{{a + b} - c} '(- (+ a b) c)))
+ (pass-if (equal? '{{a > 0} and {b >= 1}} '(and (> a 0) (>= b 1))))
+ (pass-if (equal? '{} '()))
+ (pass-if (equal? '{5} '5))
+ (pass-if (equal? '{- x} '(- x)))
+ (pass-if (equal? '{length(x) >= 6} '(>= (length x) 6)))
+ (pass-if (equal? '{f(x) + g(y) + h(z)} '(+ (f x) (g y) (h z))))
+ (pass-if (equal? '{(f a b) + (g h)} '(+ (f a b) (g h))))
+ (pass-if (equal? '{f(a b) + g(h)} '(+ (f a b) (g h))))
+ (pass-if (equal? ''{a + f(b) + x} ''(+ a (f b) x)))
+ (pass-if (equal? '{(- a) / b} '(/ (- a) b)))
+ (pass-if (equal? '{-(a) / b} '(/ (- a) b)))
+ (pass-if (equal? '{cos(q)} '(cos q)))
+ (pass-if (equal? '{e{}} '(e)))
+ (pass-if (equal? '{pi{}} '(pi)))
+ (pass-if (equal? '{'f(x)} '(quote (f x))))
+
+ (pass-if (equal? '{ (f (g h(x))) } '(f (g (h x)))))
+ (pass-if (equal? '{#(1 2 f(a) 4)} '#(1 2 (f a) 4)))
+ (pass-if (equal? '{ (f #;g(x) h(x)) } '(f (h x))))
+ (pass-if (equal? '{ (f #; g(x)[y] h(x)) } '(f (h x))))
+ (pass-if (equal? '{ (f #; g[x]{y} h(x)) } '(f (h x))))
+
+ (pass-if (equal? '{ (f #(g h(x))) } '(f #(g (h x)))))
+ (pass-if (equal? '{ (f '(g h(x))) } '(f '(g (h x)))))
+ (pass-if (equal? '{ (f `(g h(x))) } '(f `(g (h x)))))
+ (pass-if (equal? '{ (f #'(g h(x))) } '(f #'(g (h x)))))
+ (pass-if (equal? '{ (f #2((g) (h(x)))) } '(f #2((g) ((h x))))))
+
+ (pass-if (equal? '{(map - ns)} '(map - ns)))
+ (pass-if (equal? '{map(- ns)} '(map - ns)))
+ (pass-if (equal? '{n * factorial{n - 1}} '(* n (factorial (- n 1)))))
+ (pass-if (equal? '{2 * sin{- x}} '(* 2 (sin (- x)))))
+
+ (pass-if (equal? '{3 + 4 +} '($nfx$ 3 + 4 +)))
+ (pass-if (equal? '{3 + 4 + 5 +} '($nfx$ 3 + 4 + 5 +)))
+ (pass-if (equal? '{a . z} '($nfx$ a . z)))
+ (pass-if (equal? '{a + b - c} '($nfx$ a + b - c)))
+
+ (pass-if (equal? '{read(. options)} '(read . options)))
+
+ (pass-if (equal? '{a(x)(y)} '((a x) y)))
+ (pass-if (equal? '{x[a]} '($bracket-apply$ x a)))
+ (pass-if (equal? '{y[a b]} '($bracket-apply$ y a b)))
+
+ (pass-if (equal? '{f(g(x))} '(f (g x))))
+ (pass-if (equal? '{f(g(x) h(x))} '(f (g x) (h x))))
+
+
+ (pass-if (equal? '{} '()))
+ (pass-if (equal? '{e} 'e))
+ (pass-if (equal? '{e1 e2} '(e1 e2)))
+
+ (pass-if (equal? '{a . t} '($nfx$ a . t)))
+ (pass-if (equal? '{a b . t} '($nfx$ a b . t)))
+ (pass-if (equal? '{a b c . t} '($nfx$ a b c . t)))
+ (pass-if (equal? '{a b c d . t} '($nfx$ a b c d . t)))
+ (pass-if (equal? '{a + b +} '($nfx$ a + b +)))
+ (pass-if (equal? '{a + b + c +} '($nfx$ a + b + c +)))
+ (pass-if (equal? '{q + r * s} '($nfx$ q + r * s)))
+
+ ;; The following two tests will become relevant when Guile's reader
+ ;; supports datum labels, specified in SRFI-38 (External
+ ;; Representation for Data With Shared Structure).
+
+ ;;(pass-if (equal? '{#1=f(#1#)} '#1=(f #1#)))
+ ;;(pass-if (equal? '#1={a + . #1#} '($nfx$ . #1=(a + . #1#))))
+
+ (pass-if (equal? '{e()} '(e)))
+ (pass-if (equal? '{e{}} '(e)))
+ (pass-if (equal? '{e(1)} '(e 1)))
+ (pass-if (equal? '{e{1}} '(e 1)))
+ (pass-if (equal? '{e(1 2)} '(e 1 2)))
+ (pass-if (equal? '{e{1 2}} '(e (1 2))))
+ (pass-if (equal? '{f{n - 1}} '(f (- n 1))))
+ (pass-if (equal? '{f{n - 1}(x)} '((f (- n 1)) x)))
+ (pass-if (equal? '{f{n - 1}{y - 1}} '((f (- n 1)) (- y 1))))
+ (pass-if (equal? '{f{- x}[y]} '($bracket-apply$ (f (- x)) y)))
+ (pass-if (equal? '{g{- x}} '(g (- x))))
+ (pass-if (equal? '{( . e)} 'e))
+
+ (pass-if (equal? '{e[]} '($bracket-apply$ e)))
+ (pass-if (equal? '{e[1 2]} '($bracket-apply$ e 1 2)))
+ (pass-if (equal? '{e[1 . 2]} '($bracket-apply$ e 1 . 2)))
+
+ ;; Verify that source position information is not recorded if not
+ ;; asked for.
+ (with-test-prefix "no positions"
+ (pass-if "simple curly-infix list"
+ (let ((sexp (with-read-options '(curly-infix)
+ (lambda ()
+ (read-string " {1 + 2 + 3}")))))
+ (and (not (source-property sexp 'line))
+ (not (source-property sexp 'column)))))
+ (pass-if "mixed curly-infix list"
+ (let ((sexp (with-read-options '(curly-infix)
+ (lambda ()
+ (read-string " {1 + 2 * 3}")))))
+ (and (not (source-property sexp 'line))
+ (not (source-property sexp 'column)))))
+ (pass-if "singleton curly-infix list"
+ (let ((sexp (with-read-options '(curly-infix)
+ (lambda ()
+ (read-string " { 1.0 }")))))
+ (and (not (source-property sexp 'line))
+ (not (source-property sexp 'column)))))
+ (pass-if "neoteric expression"
+ (let ((sexp (with-read-options '(curly-infix)
+ (lambda ()
+ (read-string " { f(x) }")))))
+ (and (not (source-property sexp 'line))
+ (not (source-property sexp 'column))))))
+
+ ;; Verify that source position information is properly recorded.
+ (with-test-prefix "positions"
+ (pass-if "simple curly-infix list"
+ (let ((sexp (with-read-options '(curly-infix positions)
+ (lambda ()
+ (read-string " {1 + 2 + 3}")))))
+ (and (equal? (source-property sexp 'line) 0)
+ (equal? (source-property sexp 'column) 1))))
+ (pass-if "mixed curly-infix list"
+ (let ((sexp (with-read-options '(curly-infix positions)
+ (lambda ()
+ (read-string " {1 + 2 * 3}")))))
+ (and (equal? (source-property sexp 'line) 0)
+ (equal? (source-property sexp 'column) 1))))
+ (pass-if "singleton curly-infix list"
+ (let ((sexp (with-read-options '(curly-infix positions)
+ (lambda ()
+ (read-string " { 1.0 }")))))
+ (and (equal? (source-property sexp 'line) 0)
+ (equal? (source-property sexp 'column) 3))))
+ (pass-if "neoteric expression"
+ (let ((sexp (with-read-options '(curly-infix positions)
+ (lambda ()
+ (read-string " { f(x) }")))))
+ (and (equal? (source-property sexp 'line) 0)
+ (equal? (source-property sexp 'column) 3)))))
+
+ ;; Verify that neoteric expressions are recognized only within curly braces.
+ (pass-if (equal? '(a(x)(y)) '(a (x) (y))))
+ (pass-if (equal? '(x[a]) '(x [a])))
+ (pass-if (equal? '(y[a b]) '(y [a b])))
+ (pass-if (equal? '(a f{n - 1}) '(a f (- n 1))))
+ (pass-if (equal? '(a f{n - 1}(x)) '(a f (- n 1) (x))))
+ (pass-if (equal? '(a f{n - 1}[x]) '(a f (- n 1) [x])))
+ (pass-if (equal? '(a f{n - 1}{y - 1}) '(a f (- n 1) (- y 1))))
+
+ ;; Verify that bracket lists are not recognized by default.
+ (pass-if (equal? '{[]} '()))
+ (pass-if (equal? '{[a]} '(a)))
+ (pass-if (equal? '{[a b]} '(a b)))
+ (pass-if (equal? '{[a . b]} '(a . b)))
+ (pass-if (equal? '[] '()))
+ (pass-if (equal? '[a] '(a)))
+ (pass-if (equal? '[a b] '(a b)))
+ (pass-if (equal? '[a . b] '(a . b))))
+
+
+#!curly-infix-and-bracket-lists
+
+(with-test-prefix "curly-infix-and-bracket-lists"
+ ;; Verify that these neoteric expressions still work properly
+ ;; when the 'square-brackets' read option is unset (which is done by
+ ;; the '#!curly-infix-and-bracket-lists' reader directive above).
+ (pass-if (equal? '{e[]} '($bracket-apply$ e)))
+ (pass-if (equal? '{e[1 2]} '($bracket-apply$ e 1 2)))
+ (pass-if (equal? '{e[1 . 2]} '($bracket-apply$ e 1 . 2)))
+
+ ;; The following expressions are not actually part of SRFI-105, but
+ ;; they are handled when the 'curly-infix' read option is set and the
+ ;; 'square-brackets' read option is unset. This is a non-standard
+ ;; extension of SRFI-105, and follows the convention of GNU Kawa.
+ (pass-if (equal? '{[]} '($bracket-list$)))
+ (pass-if (equal? '{[a]} '($bracket-list$ a)))
+ (pass-if (equal? '{[a b]} '($bracket-list$ a b)))
+ (pass-if (equal? '{[a . b]} '($bracket-list$ a . b)))
+
+ (pass-if (equal? '[] '($bracket-list$)))
+ (pass-if (equal? '[a] '($bracket-list$ a)))
+ (pass-if (equal? '[a b] '($bracket-list$ a b)))
+ (pass-if (equal? '[a . b] '($bracket-list$ a . b))))
diff --git a/test-suite/tests/srfi-31.test b/test-suite/tests/srfi-31.test
index 8537d49..62645d9 100644
--- a/test-suite/tests/srfi-31.test
+++ b/test-suite/tests/srfi-31.test
@@ -1,6 +1,6 @@
;;;; srfi-31.test --- Test suite for Guile's SRFI-31 functions. -*- scheme -*-
;;;;
-;;;; Copyright (C) 2004, 2006, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2004, 2006, 2010, 2012 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
@@ -22,9 +22,10 @@
(with-test-prefix "rec special form"
- (pass-if-exception "bogus variable" '(misc-error . ".*")
+ (pass-if-exception "bogus variable"
+ exception:syntax-pattern-unmatched
(eval '(rec #:foo) (current-module)))
-
+
(pass-if "rec expressions"
(let ((ones-list (rec ones (cons 1 (delay ones)))))
(and (= 1 (car ones-list))
diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test
index d892b70..679e173 100644
--- a/test-suite/tests/strings.test
+++ b/test-suite/tests/strings.test
@@ -557,7 +557,67 @@
(pass-if "char 255"
(equal? '("a" "b")
(string-split (string #\a (integer->char 255) #\b)
- (integer->char 255)))))
+ (integer->char 255))))
+
+ (pass-if "empty string - char"
+ (equal? '("")
+ (string-split "" #\:)))
+
+ (pass-if "non-empty - char - no delimiters"
+ (equal? '("foobarfrob")
+ (string-split "foobarfrob" #\:)))
+
+ (pass-if "non-empty - char - delimiters"
+ (equal? '("foo" "bar" "frob")
+ (string-split "foo:bar:frob" #\:)))
+
+ (pass-if "non-empty - char - leading delimiters"
+ (equal? '("" "" "foo" "bar" "frob")
+ (string-split "::foo:bar:frob" #\:)))
+
+ (pass-if "non-empty - char - trailing delimiters"
+ (equal? '("foo" "bar" "frob" "" "")
+ (string-split "foo:bar:frob::" #\:)))
+
+ (pass-if "empty string - charset"
+ (equal? '("")
+ (string-split "" (char-set #\:))))
+
+ (pass-if "non-empty - charset - no delimiters"
+ (equal? '("foobarfrob")
+ (string-split "foobarfrob" (char-set #\:))))
+
+ (pass-if "non-empty - charset - delimiters"
+ (equal? '("foo" "bar" "frob")
+ (string-split "foo:bar:frob" (char-set #\:))))
+
+ (pass-if "non-empty - charset - leading delimiters"
+ (equal? '("" "" "foo" "bar" "frob")
+ (string-split "::foo:bar:frob" (char-set #\:))))
+
+ (pass-if "non-empty - charset - trailing delimiters"
+ (equal? '("foo" "bar" "frob" "" "")
+ (string-split "foo:bar:frob::" (char-set #\:))))
+
+ (pass-if "empty string - pred"
+ (equal? '("")
+ (string-split "" (negate char-alphabetic?))))
+
+ (pass-if "non-empty - pred - no delimiters"
+ (equal? '("foobarfrob")
+ (string-split "foobarfrob" (negate char-alphabetic?))))
+
+ (pass-if "non-empty - pred - delimiters"
+ (equal? '("foo" "bar" "frob")
+ (string-split "foo:bar:frob" (negate char-alphabetic?))))
+
+ (pass-if "non-empty - pred - leading delimiters"
+ (equal? '("" "" "foo" "bar" "frob")
+ (string-split "::foo:bar:frob" (negate char-alphabetic?))))
+
+ (pass-if "non-empty - pred - trailing delimiters"
+ (equal? '("foo" "bar" "frob" "" "")
+ (string-split "foo:bar:frob::" (negate char-alphabetic?)))))
(with-test-prefix "substring-move!"
diff --git a/test-suite/tests/structs.test b/test-suite/tests/structs.test
index 431a014..0e3b241 100644
--- a/test-suite/tests/structs.test
+++ b/test-suite/tests/structs.test
@@ -126,7 +126,49 @@
(not (or (equal? (make-ball red "Bob") (make-ball green "Bob"))
(equal? (make-ball red "Bob") (make-ball red "Bill"))))))
+
+(with-test-prefix "hash"
+
+ (pass-if "simple structs"
+ (let* ((v (make-vtable "pr"))
+ (s1 (make-struct v 0 "hello"))
+ (s2 (make-struct v 0 "hello")))
+ (= (hash s1 7777) (hash s2 7777))))
+
+ (pass-if "different structs"
+ (let* ((v (make-vtable "pr"))
+ (s1 (make-struct v 0 "hello"))
+ (s2 (make-struct v 0 "world")))
+ (or (not (= (hash s1 7777) (hash s2 7777)))
+ (throw 'unresolved))))
+
+ (pass-if "different struct types"
+ (let* ((v1 (make-vtable "pr"))
+ (v2 (make-vtable "pr"))
+ (s1 (make-struct v1 0 "hello"))
+ (s2 (make-struct v2 0 "hello")))
+ (or (not (= (hash s1 7777) (hash s2 7777)))
+ (throw 'unresolved))))
+ (pass-if "more complex structs"
+ (let ((s1 (make-ball red (string-copy "Bob")))
+ (s2 (make-ball red (string-copy "Bob"))))
+ (= (hash s1 7777) (hash s2 7777))))
+
+ (pass-if "struct with weird fields"
+ (let* ((v (make-vtable "prurph"))
+ (s1 (make-struct v 0 "hello" 123 "invisible-secret1"))
+ (s2 (make-struct v 0 "hello" 123 "invisible-secret2")))
+ (= (hash s1 7777) (hash s2 7777))))
+
+ (pass-if "cyclic structs"
+ (let* ((v (make-vtable "pw"))
+ (a (make-struct v 0 #f))
+ (b (make-struct v 0 a)))
+ (struct-set! a 0 b)
+ (and (hash a 7777) (hash b 7777) #t))))
+
+
;;
;; make-struct
;;
diff --git a/test-suite/tests/texinfo.test b/test-suite/tests/texinfo.test
index 98c44b9..8a4b593 100644
--- a/test-suite/tests/texinfo.test
+++ b/test-suite/tests/texinfo.test
@@ -208,9 +208,8 @@
(test-body "@code{arg}"
'((para (code "arg"))))
- ;; FIXME: Why no enclosing para here? Probably a bug.
(test-body "@url{arg}"
- '((uref (% (url "arg")))))
+ '((para (uref (% (url "arg"))))))
(test-body "@code{ }"
'((para (code))))
(test-body "@code{ @code{} }"
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 5d12f0c..4767d62 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -58,6 +58,20 @@
(assert-tree-il->glil with-partial-evaluation
in pat test ...))))
+(define-syntax-rule (pass-if-primitives-resolved in expected)
+ (pass-if (format #f "primitives-resolved in ~s" 'in)
+ (let* ((module (let ((m (make-module)))
+ (beautify-user-module! m)
+ m))
+ (orig (parse-tree-il 'in))
+ (resolved (expand-primitives! (resolve-primitives! orig module))))
+ (or (equal? (unparse-tree-il resolved) 'expected)
+ (begin
+ (format (current-error-port)
+ "primitive test failed: got ~s, expected ~s"
+ resolved 'expected)
+ #f)))))
+
(define-syntax pass-if-tree-il->scheme
(syntax-rules ()
((_ in pat)
@@ -70,6 +84,69 @@
(_ #f))))))
+(with-test-prefix "primitives"
+
+ (with-test-prefix "eqv?"
+
+ (pass-if-primitives-resolved
+ (primcall eqv? (toplevel x) (const #f))
+ (primcall eq? (const #f) (toplevel x)))
+
+ (pass-if-primitives-resolved
+ (primcall eqv? (toplevel x) (const ()))
+ (primcall eq? (const ()) (toplevel x)))
+
+ (pass-if-primitives-resolved
+ (primcall eqv? (const #t) (lexical x y))
+ (primcall eq? (const #t) (lexical x y)))
+
+ (pass-if-primitives-resolved
+ (primcall eqv? (const this-is-a-symbol) (toplevel x))
+ (primcall eq? (const this-is-a-symbol) (toplevel x)))
+
+ (pass-if-primitives-resolved
+ (primcall eqv? (const 42) (toplevel x))
+ (primcall eq? (const 42) (toplevel x)))
+
+ (pass-if-primitives-resolved
+ (primcall eqv? (const 42.0) (toplevel x))
+ (primcall eqv? (const 42.0) (toplevel x)))
+
+ (pass-if-primitives-resolved
+ (primcall eqv? (const #nil) (toplevel x))
+ (primcall eq? (const #nil) (toplevel x))))
+
+ (with-test-prefix "equal?"
+
+ (pass-if-primitives-resolved
+ (primcall equal? (toplevel x) (const #f))
+ (primcall eq? (const #f) (toplevel x)))
+
+ (pass-if-primitives-resolved
+ (primcall equal? (toplevel x) (const ()))
+ (primcall eq? (const ()) (toplevel x)))
+
+ (pass-if-primitives-resolved
+ (primcall equal? (const #t) (lexical x y))
+ (primcall eq? (const #t) (lexical x y)))
+
+ (pass-if-primitives-resolved
+ (primcall equal? (const this-is-a-symbol) (toplevel x))
+ (primcall eq? (const this-is-a-symbol) (toplevel x)))
+
+ (pass-if-primitives-resolved
+ (primcall equal? (const 42) (toplevel x))
+ (primcall eq? (const 42) (toplevel x)))
+
+ (pass-if-primitives-resolved
+ (primcall equal? (const 42.0) (toplevel x))
+ (primcall equal? (const 42.0) (toplevel x)))
+
+ (pass-if-primitives-resolved
+ (primcall equal? (const #nil) (toplevel x))
+ (primcall eq? (const #nil) (toplevel x)))))
+
+
(with-test-prefix "tree-il->scheme"
(pass-if-tree-il->scheme
(case-lambda ((a) a) ((b c) (list b c)))
@@ -1704,3 +1781,8 @@
#:to 'assembly)))))
(and (= (length w) 1)
(number? (string-contains (car w) "unsupported format
option"))))))))
+
+;; Local Variables:
+;; eval: (put 'pass-if-primitives-resolved 'scheme-indent-function 1)
+;; eval: (put 'pass-if-tree-il->scheme 'scheme-indent-function 1)
+;; End:
diff --git a/test-suite/tests/web-uri.test b/test-suite/tests/web-uri.test
index 4621a19..3f6e7e3 100644
--- a/test-suite/tests/web-uri.test
+++ b/test-suite/tests/web-uri.test
@@ -258,4 +258,6 @@
(equal? "foo bar" (uri-decode "foo+bar"))))
(with-test-prefix "encode"
- (pass-if (equal? "foo%20bar" (uri-encode "foo bar"))))
+ (pass-if (equal? "foo%20bar" (uri-encode "foo bar")))
+ (pass-if (equal? "foo%0a%00bar" (uri-encode "foo\n\x00bar")))
+ (pass-if (equal? "%3c%3e%5c%5e" (uri-encode "<>\\^"))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-433-gfa980bc,
Mark H Weaver <=