mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-09 21:40:33 +02:00
Merge from stable-2.0
This cherry-picks changes from stable-2.0, starting fromacd2c8e36aand ending in461b62efc9, inclusively. I did not cherry-pick patches that were already on master and did not cherry-pick ones that don't make sense on master (for example because of the port re-write). I did pick all tests though. I also did not cherry-pick the "Revert foreign objects" patch fromff98cbb643; further discussion necessary.
This commit is contained in:
Andy Wingo
commit
2badbd06f6
49 changed files with 2241 additions and 918 deletions
5
HACKING
5
HACKING
|
|
@ -1,6 +1,7 @@
|
|||
-*-text-*-
|
||||
Guile Hacking Guide
|
||||
Copyright (c) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2008, 2012 Free software Foundation, Inc.
|
||||
Copyright (c) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2008, 2012,
|
||||
2015 Free software Foundation, Inc.
|
||||
|
||||
Permission is granted to anyone to make or distribute verbatim copies
|
||||
of this document as received, in any medium, provided that the
|
||||
|
|
@ -69,7 +70,7 @@ gettext --- a system for rigging a program so that it can output its
|
|||
itself.
|
||||
|
||||
flex --- a scanner generator. It's probably not essential to have the
|
||||
latest version.
|
||||
latest version; Flex 2.5.37 is known to work.
|
||||
|
||||
One false move and you will be lost in a little maze of automatically
|
||||
generated files, all different.
|
||||
|
|
|
|||
20
NEWS
20
NEWS
|
|
@ -738,6 +738,26 @@ longer installed to the libdir. This change should be transparent to
|
|||
users, but packagers may be interested.
|
||||
|
||||
|
||||
|
||||
Changes in 2.0.12 (since 2.0.11):
|
||||
|
||||
[Note: these changes come to 2.2 via 2.0 branch, but 2.0.12 hasn't been
|
||||
released yet at the time of this writing.]
|
||||
|
||||
* Notable changes
|
||||
|
||||
** The #!r6rs directive now influences read syntax
|
||||
|
||||
The #!r6rs directive now changes the per-port reader options to make
|
||||
Guile's reader conform more closely to the R6RS syntax. In particular:
|
||||
|
||||
- It makes the reader case sensitive.
|
||||
- It disables the recognition of keyword syntax in conflict with the
|
||||
R6RS (and R5RS).
|
||||
- It enables the `square-brackets', `hungry-eol-escapes' and
|
||||
`r6rs-hex-escapes' reader options.
|
||||
|
||||
|
||||
|
||||
Changes in 2.0.11 (since 2.0.10):
|
||||
|
||||
|
|
|
|||
3
THANKS
3
THANKS
|
|
@ -134,6 +134,7 @@ For fixes or providing information which led to a fix:
|
|||
Dan McMahill
|
||||
Roger Mc Murtrie
|
||||
Scott McPeak
|
||||
David Michael
|
||||
Glenn Michaels
|
||||
Andrew Milkowski
|
||||
Tim Mooney
|
||||
|
|
@ -170,6 +171,7 @@ For fixes or providing information which led to a fix:
|
|||
Dale Smith
|
||||
Cesar Strauss
|
||||
Klaus Stehle
|
||||
Kouhei Sutou
|
||||
Rainer Tammer
|
||||
Frank Terbeck
|
||||
Samuel Thibault
|
||||
|
|
@ -199,6 +201,7 @@ For fixes or providing information which led to a fix:
|
|||
Jon Wilson
|
||||
Andy Wingo
|
||||
Keith Wright
|
||||
Ricardo Wurmus
|
||||
William Xu
|
||||
Atom X Zane
|
||||
|
||||
|
|
|
|||
|
|
@ -752,6 +752,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
|
|||
# isblank - available as a GNU extension or in C99
|
||||
# _NSGetEnviron - Darwin specific
|
||||
# strcoll_l, newlocale, uselocale, utimensat - POSIX.1-2008
|
||||
# strtol_l - non-POSIX, found in glibc
|
||||
# fork - unavailable on Windows
|
||||
# sched_getaffinity, sched_setaffinity - GNU extensions (glibc)
|
||||
# sendfile - non-POSIX, found in glibc
|
||||
|
|
@ -765,8 +766,8 @@ AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \
|
|||
strdup system usleep atexit on_exit chown link fcntl ttyname getpwent \
|
||||
getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp \
|
||||
index bcopy memcpy rindex truncate unsetenv isblank _NSGetEnviron \
|
||||
strcoll strcoll_l newlocale uselocale utimensat sched_getaffinity \
|
||||
sched_setaffinity sendfile])
|
||||
strcoll strcoll_l strtol_l newlocale uselocale utimensat \
|
||||
sched_getaffinity sched_setaffinity sendfile])
|
||||
|
||||
# Reasons for testing:
|
||||
# netdb.h - not in mingw
|
||||
|
|
@ -1124,7 +1125,7 @@ if test "$enable_regex" = yes; then
|
|||
AC_DEFINE([ENABLE_REGEX], 1, [Define when regex support is enabled.])
|
||||
fi
|
||||
|
||||
AC_REPLACE_FUNCS([strerror memmove mkstemp])
|
||||
AC_REPLACE_FUNCS([strerror memmove])
|
||||
|
||||
# Reasons for testing:
|
||||
# asinh, acosh, atanh, trunc - C99 standard, generally not available on
|
||||
|
|
|
|||
|
|
@ -125,7 +125,7 @@ is being run interactively.
|
|||
Compile source files automatically (default behavior).
|
||||
.
|
||||
.TP
|
||||
.B --no-autocompile
|
||||
.B --no-auto-compile
|
||||
Disable automatic source file compilation.
|
||||
.
|
||||
.TP
|
||||
|
|
|
|||
|
|
@ -2322,7 +2322,7 @@ You may use @code{set-record-type-printer!} to customize the default printing
|
|||
behavior of records. This is a Guile extension and is not part of SRFI-9. It
|
||||
is located in the @nicode{(srfi srfi-9 gnu)} module.
|
||||
|
||||
@deffn {Scheme Syntax} set-record-type-printer! name proc
|
||||
@deffn {Scheme Syntax} set-record-type-printer! type proc
|
||||
Where @var{type} corresponds to the first argument of @code{define-record-type},
|
||||
and @var{proc} is a procedure accepting two arguments, the record to print, and
|
||||
an output port.
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
@c -*-texinfo-*-
|
||||
@c This is part of the GNU Guile Reference Manual.
|
||||
@c Copyright (C) 1996, 1997, 2000-2004, 2006-2014
|
||||
@c Copyright (C) 1996, 1997, 2000-2004, 2006-2015
|
||||
@c Free Software Foundation, Inc.
|
||||
@c See the file guile.texi for copying conditions.
|
||||
|
||||
|
|
@ -4983,6 +4983,12 @@ in one of the most commonly available encoding formats.
|
|||
@result{} #vu8(99 97 102 195 169)
|
||||
@end lisp
|
||||
|
||||
@deftypefn {Scheme Procedure} {} string-utf8-length str
|
||||
@deftypefnx {C function} SCM scm_string_utf8_length (str)
|
||||
@deftypefnx {C function} size_t scm_c_string_utf8_length (str)
|
||||
Return the number of bytes in the UTF-8 representation of @var{str}.
|
||||
@end deftypefn
|
||||
|
||||
@deffn {Scheme Procedure} string->utf8 str
|
||||
@deffnx {Scheme Procedure} string->utf16 str [endianness]
|
||||
@deffnx {Scheme Procedure} string->utf32 str [endianness]
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
@c -*-texinfo-*-
|
||||
@c This is part of the GNU Guile Reference Manual.
|
||||
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009, 2010, 2011,
|
||||
@c 2012, 2013, 2014 Free Software Foundation, Inc.
|
||||
@c Copyright (C) 1996, 1997, 2000-2004, 2009-2015
|
||||
@c Free Software Foundation, Inc.
|
||||
@c See the file guile.texi for copying conditions.
|
||||
|
||||
@node Macros
|
||||
|
|
@ -618,9 +618,9 @@ won't have access to the binding of @code{it}.
|
|||
|
||||
But they can, if we explicitly introduce a binding via @code{datum->syntax}.
|
||||
|
||||
@deffn {Scheme Procedure} datum->syntax for-syntax datum
|
||||
@deffn {Scheme Procedure} datum->syntax template-id datum
|
||||
Create a syntax object that wraps @var{datum}, within the lexical context
|
||||
corresponding to the syntax object @var{for-syntax}.
|
||||
corresponding to the identifier @var{template-id}.
|
||||
@end deffn
|
||||
|
||||
For completeness, we should mention that it is possible to strip the metadata
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
@c -*-texinfo-*-
|
||||
@c This is part of the GNU Guile Reference Manual.
|
||||
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009, 2010, 2012, 2013, 2014
|
||||
@c Copyright (C) 1996, 1997, 2000-2004, 2009, 2010, 2012-2016
|
||||
@c Free Software Foundation, Inc.
|
||||
@c See the file guile.texi for copying conditions.
|
||||
|
||||
|
|
@ -36,7 +36,7 @@ explicitly. It is called automatically when appropriate.
|
|||
Protects @var{obj} from being freed by the garbage collector, when it
|
||||
otherwise might be. When you are done with the object, call
|
||||
@code{scm_gc_unprotect_object} on the object. Calls to
|
||||
@code{scm_gc_protect}/@code{scm_gc_unprotect_object} can be nested, and
|
||||
@code{scm_gc_protect_object}/@code{scm_gc_unprotect_object} can be nested, and
|
||||
the object remains protected until it has been unprotected as many times
|
||||
as it was protected. It is an error to unprotect an object more times
|
||||
than it has been protected. Returns the SCM object it was passed.
|
||||
|
|
|
|||
|
|
@ -171,8 +171,8 @@ of @code{@@} and should only be used as a last resort or for
|
|||
debugging, for example.
|
||||
|
||||
Note that just as with a @code{use-modules} statement, any module that
|
||||
has not yet been loaded yet will be loaded when referenced by a
|
||||
@code{@@} or @code{@@@@} form.
|
||||
has not yet been loaded will be loaded when referenced by a @code{@@} or
|
||||
@code{@@@@} form.
|
||||
|
||||
You can also use the @code{@@} and @code{@@@@} syntaxes as the target
|
||||
of a @code{set!} when the binding refers to a variable.
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
@c -*-texinfo-*-
|
||||
@c This is part of the GNU Guile Reference Manual.
|
||||
@c Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015
|
||||
@c Copyright (C) 2008-2016
|
||||
@c Free Software Foundation, Inc.
|
||||
@c See the file guile.texi for copying conditions.
|
||||
|
||||
|
|
@ -363,7 +363,7 @@ Sets a variable in the current procedure's module.
|
|||
@end deftp
|
||||
|
||||
@deftp {Scheme Variable} <toplevel-define> src name exp
|
||||
@deftpx {External Representation} (define (toplevel @var{name}) @var{exp})
|
||||
@deftpx {External Representation} (define @var{name} @var{exp})
|
||||
Defines a new top-level variable in the current procedure's module.
|
||||
@end deftp
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
@c -*-texinfo-*-
|
||||
@c This is part of the GNU Guile Reference Manual.
|
||||
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2010
|
||||
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2010, 2015
|
||||
@c Free Software Foundation, Inc.
|
||||
@c See the file guile.texi for copying conditions.
|
||||
|
||||
|
|
@ -339,7 +339,7 @@ actually garbage, and should be freed. In practice, this is not a
|
|||
problem. The alternative, an explicitly maintained list of local
|
||||
variable addresses, is effectively much less reliable, due to programmer
|
||||
error. Interested readers should see the BDW-GC web page at
|
||||
@uref{http://www.hpl.hp.com/personal/Hans_Boehm/gc}, for more
|
||||
@uref{http://www.hboehm.info/gc/}, for more
|
||||
information.
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@
|
|||
This manual documents Guile version @value{VERSION}.
|
||||
|
||||
Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2009,
|
||||
2010, 2011, 2012, 2013, 2014 Free Software Foundation.
|
||||
2010, 2011, 2012, 2013, 2014, 2015, 2016 Free Software Foundation.
|
||||
|
||||
Permission is granted to copy, distribute and/or modify this document
|
||||
under the terms of the GNU Free Documentation License, Version 1.3 or
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
@c -*-texinfo-*-
|
||||
@c This is part of the GNU Guile Reference Manual.
|
||||
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2010,
|
||||
@c 2011, 2013, 2014 Free Software Foundation, Inc.
|
||||
@c Copyright (C) 1996-1997, 2000-2005, 2010-2011, 2013-2016
|
||||
@c Free Software Foundation, Inc.
|
||||
@c See the file guile.texi for copying conditions.
|
||||
|
||||
@node General Libguile Concepts
|
||||
|
|
@ -197,7 +197,7 @@ sections, function arguments or local variables on the C and Scheme
|
|||
stacks, and values in machine registers. Other references to @code{SCM}
|
||||
objects, such as those in other random data structures in the C heap
|
||||
that contain fields of type @code{SCM}, can be made visible to the
|
||||
garbage collector by calling the functions @code{scm_gc_protect} or
|
||||
garbage collector by calling the functions @code{scm_gc_protect_object} or
|
||||
@code{scm_permanent_object}. Collectively, these values form the ``root
|
||||
set'' of garbage collection; any value on the heap that is referenced
|
||||
directly or indirectly by a member of the root set is preserved, and all
|
||||
|
|
|
|||
|
|
@ -3,6 +3,10 @@
|
|||
@c Copyright (C) 2013 Free Software Foundation, Inc.
|
||||
@c See the file guile.texi for copying conditions.
|
||||
|
||||
@c SXPath documentation based on SXPath.scm by Oleg Kiselyov,
|
||||
@c which is in the public domain according to <http://okmij.org/ftp/>
|
||||
@c and <http://ssax.sourceforge.net/>.
|
||||
|
||||
@node SXML
|
||||
@section SXML
|
||||
|
||||
|
|
@ -17,7 +21,7 @@ fragment:
|
|||
may be represented with the following SXML:
|
||||
|
||||
@example
|
||||
(parrot (@@ (type "African Grey)) (name "Alfie"))
|
||||
(parrot (@@ (type "African Grey")) (name "Alfie"))
|
||||
@end example
|
||||
|
||||
SXML is very general, and is capable of representing all of XML.
|
||||
|
|
@ -28,14 +32,14 @@ Guile includes several facilities for working with XML and SXML:
|
|||
parsers, serializers, and transformers.
|
||||
|
||||
@menu
|
||||
* SXML Overview:: XML, as it was meant to be
|
||||
* Reading and Writing XML:: Convenient XML parsing and serializing
|
||||
* SSAX:: Custom functional-style XML parsers
|
||||
* Transforming SXML:: Munging SXML with @code{pre-post-order}
|
||||
* SXML Tree Fold:: Fold-based SXML transformations
|
||||
* SXPath:: XPath for SXML
|
||||
* sxml apply-templates:: A more XSLT-like approach to SXML transformations
|
||||
* sxml ssax input-parse:: The SSAX tokenizer, optimized for Guile
|
||||
* SXML Overview:: XML, as it was meant to be
|
||||
* Reading and Writing XML:: Convenient XML parsing and serializing
|
||||
* SSAX:: Custom functional-style XML parsers
|
||||
* Transforming SXML:: Munging SXML with @code{pre-post-order}
|
||||
* SXML Tree Fold:: Fold-based SXML transformations
|
||||
* SXPath:: XPath for SXML
|
||||
* sxml ssax input-parse:: The SSAX tokenizer, optimized for Guile
|
||||
* sxml apply-templates:: A more XSLT-like approach to SXML transformations
|
||||
@end menu
|
||||
|
||||
@node SXML Overview
|
||||
|
|
@ -250,8 +254,8 @@ internal and external parsed entities, user-controlled handling of
|
|||
whitespace, and validation. This module therefore is intended to be a
|
||||
framework, a set of ``Lego blocks'' you can use to build a parser
|
||||
following any discipline and performing validation to any degree. As an
|
||||
example of the parser construction, this file includes a semi-validating
|
||||
SXML parser.
|
||||
example of the parser construction, the source file includes a
|
||||
semi-validating SXML parser.
|
||||
|
||||
SSAX has a ``sequential'' feel of SAX yet a ``functional style'' of DOM.
|
||||
Like a SAX parser, the framework scans the document only once and
|
||||
|
|
@ -725,95 +729,323 @@ location path is a relative path applied to the root node.
|
|||
Similarly to XPath, SXPath defines full and abbreviated notations for
|
||||
location paths. In both cases, the abbreviated notation can be
|
||||
mechanically expanded into the full form by simple rewriting rules. In
|
||||
case of SXPath the corresponding rules are given as comments to a sxpath
|
||||
function, below. The regression test suite at the end of this file shows
|
||||
a representative sample of SXPaths in both notations, juxtaposed with
|
||||
the corresponding XPath expressions. Most of the samples are borrowed
|
||||
literally from the XPath specification, while the others are adjusted
|
||||
for our running example, tree1.
|
||||
the case of SXPath the corresponding rules are given in the
|
||||
documentation of the @code{sxpath} procedure.
|
||||
@xref{sxpath-procedure-docs,,SXPath procedure documentation}.
|
||||
|
||||
The regression test suite at the end of the file @file{SXPATH-old.scm}
|
||||
shows a representative sample of SXPaths in both notations, juxtaposed
|
||||
with the corresponding XPath expressions. Most of the samples are
|
||||
borrowed literally from the XPath specification.
|
||||
|
||||
Much of the following material is taken from the SXPath sources by Oleg
|
||||
Kiselyov et al.
|
||||
|
||||
@subsubsection Basic Converters and Applicators
|
||||
|
||||
A converter is a function mapping a nodeset (or a single node) to another
|
||||
nodeset. Its type can be represented like this:
|
||||
|
||||
@example
|
||||
type Converter = Node|Nodeset -> Nodeset
|
||||
@end example
|
||||
|
||||
A converter can also play the role of a predicate: in that case, if a
|
||||
converter, applied to a node or a nodeset, yields a non-empty nodeset,
|
||||
the converter-predicate is deemed satisfied. Likewise, an empty nodeset
|
||||
is equivalent to @code{#f} in denoting failure.
|
||||
|
||||
@subsubsection Usage
|
||||
@deffn {Scheme Procedure} nodeset? x
|
||||
Return @code{#t} if @var{x} is a nodeset.
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} node-typeof? crit
|
||||
This function implements a 'Node test' as defined in Sec. 2.3 of the
|
||||
XPath document. A node test is one of the components of a location
|
||||
step. It is also a converter-predicate in SXPath.
|
||||
|
||||
The function @code{node-typeof?} takes a type criterion and returns a
|
||||
function, which, when applied to a node, will tell if the node satisfies
|
||||
the test.
|
||||
|
||||
The criterion @var{crit} is a symbol, one of the following:
|
||||
|
||||
@table @code
|
||||
@item id
|
||||
tests if the node has the right name (id)
|
||||
|
||||
@item @@
|
||||
tests if the node is an <attributes-coll>
|
||||
|
||||
@item *
|
||||
tests if the node is an <Element>
|
||||
|
||||
@item *text*
|
||||
tests if the node is a text node
|
||||
|
||||
@item *PI*
|
||||
tests if the node is a PI (processing instruction) node
|
||||
|
||||
@item *any*
|
||||
@code{#t} for any type of node
|
||||
@end table
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} node-eq? other
|
||||
A curried equivalence converter predicate that takes a node @var{other}
|
||||
and returns a function that takes another node. The two nodes are
|
||||
compared using @code{eq?}.
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} node-equal? other
|
||||
A curried equivalence converter predicate that takes a node @var{other}
|
||||
and returns a function that takes another node. The two nodes are
|
||||
compared using @code{equal?}.
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} node-pos n
|
||||
Select the @var{n}'th element of a nodeset and return as a singular
|
||||
nodeset. If the @var{n}'th element does not exist, return an empty
|
||||
nodeset. If @var{n} is a negative number the node is picked from the
|
||||
tail of the list.
|
||||
|
||||
@example
|
||||
((node-pos 1) nodeset) ; return the the head of the nodeset (if exists)
|
||||
((node-pos 2) nodeset) ; return the node after that (if exists)
|
||||
((node-pos -1) nodeset) ; selects the last node of a non-empty nodeset
|
||||
((node-pos -2) nodeset) ; selects the last but one node, if exists.
|
||||
@end example
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} filter pred?
|
||||
@verbatim
|
||||
-- Scheme Procedure: filter pred list
|
||||
Return all the elements of 2nd arg LIST that satisfy predicate
|
||||
PRED. The list is not disordered - elements that appear in the
|
||||
result list occur in the same order as they occur in the argument
|
||||
list. The returned list may share a common tail with the argument
|
||||
list. The dynamic order in which the various applications of pred
|
||||
are made is not specified.
|
||||
|
||||
(filter even? '(0 7 8 8 43 -4)) => (0 8 8 -4)
|
||||
|
||||
|
||||
@end verbatim
|
||||
A filter applicator, which introduces a filtering context. The argument
|
||||
converter @var{pred?} is considered a predicate, with either @code{#f}
|
||||
or @code{nil} meaning failure.
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} take-until pred?
|
||||
@example
|
||||
take-until:: Converter -> Converter, or
|
||||
take-until:: Pred -> Node|Nodeset -> Nodeset
|
||||
@end example
|
||||
|
||||
Given a converter-predicate @var{pred?} and a nodeset, apply the
|
||||
predicate to each element of the nodeset, until the predicate yields
|
||||
anything but @code{#f} or @code{nil}. Return the elements of the input
|
||||
nodeset that have been processed until that moment (that is, which fail
|
||||
the predicate).
|
||||
|
||||
@code{take-until} is a variation of the @code{filter} above:
|
||||
@code{take-until} passes elements of an ordered input set up to (but not
|
||||
including) the first element that satisfies the predicate. The nodeset
|
||||
returned by @code{((take-until (not pred)) nset)} is a subset -- to be
|
||||
more precise, a prefix -- of the nodeset returned by @code{((filter
|
||||
pred) nset)}.
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} take-after pred?
|
||||
@example
|
||||
take-after:: Converter -> Converter, or
|
||||
take-after:: Pred -> Node|Nodeset -> Nodeset
|
||||
@end example
|
||||
|
||||
Given a converter-predicate @var{pred?} and a nodeset, apply the
|
||||
predicate to each element of the nodeset, until the predicate yields
|
||||
anything but @code{#f} or @code{nil}. Return the elements of the input
|
||||
nodeset that have not been processed: that is, return the elements of
|
||||
the input nodeset that follow the first element that satisfied the
|
||||
predicate.
|
||||
|
||||
@code{take-after} along with @code{take-until} partition an input
|
||||
nodeset into three parts: the first element that satisfies a predicate,
|
||||
all preceding elements and all following elements.
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} map-union proc lst
|
||||
Apply @var{proc} to each element of @var{lst} and return the list of results.
|
||||
If @var{proc} returns a nodeset, splice it into the result
|
||||
|
||||
From another point of view, @code{map-union} is a function
|
||||
@code{Converter->Converter}, which places an argument-converter in a joining
|
||||
context.
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} node-reverse node-or-nodeset
|
||||
@example
|
||||
node-reverse :: Converter, or
|
||||
node-reverse:: Node|Nodeset -> Nodeset
|
||||
@end example
|
||||
|
||||
Reverses the order of nodes in the nodeset. This basic converter is
|
||||
needed to implement a reverse document order (see the XPath
|
||||
Recommendation).
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} node-trace title
|
||||
@example
|
||||
node-trace:: String -> Converter
|
||||
@end example
|
||||
|
||||
@code{(node-trace title)} is an identity converter. In addition it
|
||||
prints out the node or nodeset it is applied to, prefixed with the
|
||||
@var{title}. This converter is very useful for debugging.
|
||||
@end deffn
|
||||
|
||||
@subsubsection Converter Combinators
|
||||
|
||||
Combinators are higher-order functions that transmogrify a converter or
|
||||
glue a sequence of converters into a single, non-trivial converter. The
|
||||
goal is to arrive at converters that correspond to XPath location paths.
|
||||
|
||||
From a different point of view, a combinator is a fixed, named
|
||||
@dfn{pattern} of applying converters. Given below is a complete set of
|
||||
such patterns that together implement XPath location path specification.
|
||||
As it turns out, all these combinators can be built from a small number
|
||||
of basic blocks: regular functional composition, @code{map-union} and
|
||||
@code{filter} applicators, and the nodeset union.
|
||||
|
||||
@deffn {Scheme Procedure} select-kids test-pred?
|
||||
@code{select-kids} takes a converter (or a predicate) as an argument and
|
||||
returns another converter. The resulting converter applied to a nodeset
|
||||
returns an ordered subset of its children that satisfy the predicate
|
||||
@var{test-pred?}.
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} node-self pred?
|
||||
@verbatim
|
||||
-- Scheme Procedure: filter pred list
|
||||
Return all the elements of 2nd arg LIST that satisfy predicate
|
||||
PRED. The list is not disordered - elements that appear in the
|
||||
result list occur in the same order as they occur in the argument
|
||||
list. The returned list may share a common tail with the argument
|
||||
list. The dynamic order in which the various applications of pred
|
||||
are made is not specified.
|
||||
|
||||
(filter even? '(0 7 8 8 43 -4)) => (0 8 8 -4)
|
||||
|
||||
|
||||
@end verbatim
|
||||
Similar to @code{select-kids} except that the predicate @var{pred?} is
|
||||
applied to the node itself rather than to its children. The resulting
|
||||
nodeset will contain either one component, or will be empty if the node
|
||||
failed the predicate.
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} node-join . selectors
|
||||
@example
|
||||
node-join:: [LocPath] -> Node|Nodeset -> Nodeset, or
|
||||
node-join:: [Converter] -> Converter
|
||||
@end example
|
||||
|
||||
Join the sequence of location steps or paths as described above.
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} node-reduce . converters
|
||||
@example
|
||||
node-reduce:: [LocPath] -> Node|Nodeset -> Nodeset, or
|
||||
node-reduce:: [Converter] -> Converter
|
||||
@end example
|
||||
|
||||
A regular functional composition of converters. From a different point
|
||||
of view, @code{((apply node-reduce converters) nodeset)} is equivalent
|
||||
to @code{(foldl apply nodeset converters)}, i.e., folding, or reducing,
|
||||
a list of converters with the nodeset as a seed.
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} node-or . converters
|
||||
@example
|
||||
node-or:: [Converter] -> Converter
|
||||
@end example
|
||||
|
||||
This combinator applies all converters to a given node and produces the
|
||||
union of their results. This combinator corresponds to a union
|
||||
(@code{|} operation) for XPath location paths.
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} node-closure test-pred?
|
||||
@example
|
||||
node-closure:: Converter -> Converter
|
||||
@end example
|
||||
|
||||
Select all @emph{descendants} of a node that satisfy a
|
||||
converter-predicate @var{test-pred?}. This combinator is similar to
|
||||
@code{select-kids} but applies to grand... children as well. This
|
||||
combinator implements the @code{descendant::} XPath axis. Conceptually,
|
||||
this combinator can be expressed as
|
||||
|
||||
@example
|
||||
(define (node-closure f)
|
||||
(node-or
|
||||
(select-kids f)
|
||||
(node-reduce (select-kids (node-typeof? '*)) (node-closure f))))
|
||||
@end example
|
||||
|
||||
This definition, as written, looks somewhat like a fixpoint, and it will
|
||||
run forever. It is obvious however that sooner or later
|
||||
@code{(select-kids (node-typeof? '*))} will return an empty nodeset. At
|
||||
this point further iterations will no longer affect the result and can
|
||||
be stopped.
|
||||
@end deffn
|
||||
|
||||
@deffn {Scheme Procedure} node-parent rootnode
|
||||
@example
|
||||
node-parent:: RootNode -> Converter
|
||||
@end example
|
||||
|
||||
@code{(node-parent rootnode)} yields a converter that returns a parent
|
||||
of a node it is applied to. If applied to a nodeset, it returns the
|
||||
list of parents of nodes in the nodeset. The @var{rootnode} does not
|
||||
have to be the root node of the whole SXML tree -- it may be a root node
|
||||
of a branch of interest.
|
||||
|
||||
Given the notation of Philip Wadler's paper on semantics of XSLT,
|
||||
|
||||
@verbatim
|
||||
parent(x) = { y | y=subnode*(root), x=subnode(y) }
|
||||
@end verbatim
|
||||
|
||||
Therefore, @code{node-parent} is not the fundamental converter: it can
|
||||
be expressed through the existing ones. Yet @code{node-parent} is a
|
||||
rather convenient converter. It corresponds to a @code{parent::} axis
|
||||
of SXPath. Note that the @code{parent::} axis can be used with an
|
||||
attribute node as well.
|
||||
@end deffn
|
||||
|
||||
@anchor{sxpath-procedure-docs}
|
||||
@deffn {Scheme Procedure} sxpath path
|
||||
Evaluate an abbreviated SXPath.
|
||||
|
||||
@example
|
||||
sxpath:: AbbrPath -> Converter, or
|
||||
sxpath:: AbbrPath -> Node|Nodeset -> Nodeset
|
||||
@end example
|
||||
|
||||
@var{path} is a list. It is translated to the full SXPath according to
|
||||
the following rewriting rules:
|
||||
|
||||
@example
|
||||
(sxpath '())
|
||||
@result{} (node-join)
|
||||
|
||||
(sxpath '(path-component ...))
|
||||
@result{} (node-join (sxpath1 path-component) (sxpath '(...)))
|
||||
|
||||
(sxpath1 '//)
|
||||
@result{} (node-or
|
||||
(node-self (node-typeof? '*any*))
|
||||
(node-closure (node-typeof? '*any*)))
|
||||
|
||||
(sxpath1 '(equal? x))
|
||||
@result{} (select-kids (node-equal? x))
|
||||
|
||||
(sxpath1 '(eq? x))
|
||||
@result{} (select-kids (node-eq? x))
|
||||
|
||||
(sxpath1 ?symbol)
|
||||
@result{} (select-kids (node-typeof? ?symbol)
|
||||
|
||||
(sxpath1 procedure)
|
||||
@result{} procedure
|
||||
|
||||
(sxpath1 '(?symbol ...))
|
||||
@result{} (sxpath1 '((?symbol) ...))
|
||||
|
||||
(sxpath1 '(path reducer ...))
|
||||
@result{} (node-reduce (sxpath path) (sxpathr reducer) ...)
|
||||
|
||||
(sxpathr number)
|
||||
@result{} (node-pos number)
|
||||
|
||||
(sxpathr path-filter)
|
||||
@result{} (filter (sxpath path-filter))
|
||||
@end example
|
||||
@end deffn
|
||||
|
||||
@node sxml ssax input-parse
|
||||
|
|
|
|||
|
|
@ -747,9 +747,9 @@ a resource.
|
|||
@deftypevr {HTTP Header} List content-type
|
||||
The MIME type of a resource, as a symbol, along with any parameters.
|
||||
@example
|
||||
(parse-header 'content-length "text/plain")
|
||||
(parse-header 'content-type "text/plain")
|
||||
@result{} (text/plain)
|
||||
(parse-header 'content-length "text/plain;charset=utf-8")
|
||||
(parse-header 'content-type "text/plain;charset=utf-8")
|
||||
@result{} (text/plain (charset . "utf-8"))
|
||||
@end example
|
||||
Note that the @code{charset} parameter is something is a misnomer, and
|
||||
|
|
|
|||
1
libguile/.gitignore
vendored
1
libguile/.gitignore
vendored
|
|
@ -13,3 +13,4 @@ libpath.h
|
|||
scmconfig.h
|
||||
version.h
|
||||
vm-i-*.i
|
||||
*.NEW
|
||||
|
|
|
|||
|
|
@ -455,7 +455,7 @@ EXTRA_libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = _scm.h \
|
|||
memmove.c strerror.c \
|
||||
dynl.c regex-posix.c \
|
||||
posix.c net_db.c socket.c \
|
||||
debug-malloc.c mkstemp.c \
|
||||
debug-malloc.c \
|
||||
win32-uname.c \
|
||||
locale-categories.h
|
||||
|
||||
|
|
@ -815,13 +815,13 @@ MKDEP = gcc -M -MG $(DEFS) $(AM_CPPFLAGS) $(CPPFLAGS) $(CFLAGS)
|
|||
|
||||
# Write $(srcdir)/cpp-{E,SIG}.syms.NEW if there are any not-yet-seen
|
||||
# ("new" to us) E* or SIG* symbols in <errno.h> or <signal.h>, respectively.
|
||||
chknew-E chknew-SIG: \
|
||||
chknew-E chknew-SIG:
|
||||
@bit=`echo $@ | sed s/^chknew-//` ; \
|
||||
old="$(srcdir)/cpp-$$bit.syms" ; \
|
||||
echo "#include <$${bit}.h>" \
|
||||
| sed 's/E/errno/;s/SIG/signal/' \
|
||||
| gcc -dM -E - \
|
||||
| sed 's/^#define //;/^'$$bit'[A-Z][A-Z]*/!d;s/ .*//' \
|
||||
| sed 's/^#define //;/^'$$bit'[0-9A-Z][0-9A-Z]* /!d;s/ .*//' \
|
||||
| sort | diff -u $$old - | sed '1,2d;/^+/!d;s/^.//' \
|
||||
> TMP ; \
|
||||
if [ -s TMP ] ; then new="$$old.NEW" ; \
|
||||
|
|
|
|||
|
|
@ -6,11 +6,14 @@ EADV
|
|||
EAFNOSUPPORT
|
||||
EAGAIN
|
||||
EALREADY
|
||||
EAUTH
|
||||
EBACKGROUND
|
||||
EBADE
|
||||
EBADF
|
||||
EBADFD
|
||||
EBADMSG
|
||||
EBADR
|
||||
EBADRPC
|
||||
EBADRQC
|
||||
EBADSLT
|
||||
EBFONT
|
||||
|
|
@ -22,18 +25,25 @@ ECOMM
|
|||
ECONNABORTED
|
||||
ECONNREFUSED
|
||||
ECONNRESET
|
||||
ED
|
||||
EDEADLK
|
||||
EDEADLOCK
|
||||
EDESTADDRREQ
|
||||
EDIED
|
||||
EDOM
|
||||
EDOTDOT
|
||||
EDQUOT
|
||||
EEXIST
|
||||
EFAULT
|
||||
EFBIG
|
||||
EFTYPE
|
||||
EGRATUITOUS
|
||||
EGREGIOUS
|
||||
EHOSTDOWN
|
||||
EHOSTUNREACH
|
||||
EHWPOISON
|
||||
EIDRM
|
||||
EIEIO
|
||||
EILSEQ
|
||||
EINPROGRESS
|
||||
EINTR
|
||||
|
|
@ -63,6 +73,7 @@ EMSGSIZE
|
|||
EMULTIHOP
|
||||
ENAMETOOLONG
|
||||
ENAVAIL
|
||||
ENEEDAUTH
|
||||
ENETDOWN
|
||||
ENETRESET
|
||||
ENETUNREACH
|
||||
|
|
@ -104,6 +115,10 @@ EOWNERDEAD
|
|||
EPERM
|
||||
EPFNOSUPPORT
|
||||
EPIPE
|
||||
EPROCLIM
|
||||
EPROCUNAVAIL
|
||||
EPROGMISMATCH
|
||||
EPROGUNAVAIL
|
||||
EPROTO
|
||||
EPROTONOSUPPORT
|
||||
EPROTOTYPE
|
||||
|
|
@ -112,7 +127,9 @@ EREMCHG
|
|||
EREMOTE
|
||||
EREMOTEIO
|
||||
ERESTART
|
||||
ERFKILL
|
||||
EROFS
|
||||
ERPCMISMATCH
|
||||
ESHUTDOWN
|
||||
ESOCKTNOSUPPORT
|
||||
ESPIPE
|
||||
|
|
|
|||
|
|
@ -5,17 +5,16 @@ SIGBUS
|
|||
SIGCHLD
|
||||
SIGCLD
|
||||
SIGCONT
|
||||
SIGEV_NONE
|
||||
SIGEV_SIGNAL
|
||||
SIGEV_THREAD
|
||||
SIGEV_THREAD_ID
|
||||
SIGEMT
|
||||
SIGFPE
|
||||
SIGHUP
|
||||
SIGILL
|
||||
SIGINFO
|
||||
SIGINT
|
||||
SIGIO
|
||||
SIGIOT
|
||||
SIGKILL
|
||||
SIGLOST
|
||||
SIGPIPE
|
||||
SIGPOLL
|
||||
SIGPROF
|
||||
|
|
|
|||
|
|
@ -992,8 +992,8 @@ SCM_DEFINE (scm_fsync, "fsync", 1, 0, 0,
|
|||
#ifdef HAVE_SYMLINK
|
||||
SCM_DEFINE (scm_symlink, "symlink", 2, 0, 0,
|
||||
(SCM oldpath, SCM newpath),
|
||||
"Create a symbolic link named @var{oldpath} with the value\n"
|
||||
"(i.e., pointing to) @var{newpath}. The return value is\n"
|
||||
"Create a symbolic link named @var{newpath} with the value\n"
|
||||
"(i.e., pointing to) @var{oldpath}. The return value is\n"
|
||||
"unspecified.")
|
||||
#define FUNC_NAME s_scm_symlink
|
||||
{
|
||||
|
|
|
|||
|
|
@ -376,10 +376,16 @@ main (int argc, char *argv[])
|
|||
|
||||
#if defined GUILE_USE_64_CALLS && defined HAVE_STAT64
|
||||
pf ("typedef scm_t_int64 scm_t_off;\n");
|
||||
pf ("#define SCM_T_OFF_MAX SCM_T_INT64_MAX\n");
|
||||
pf ("#define SCM_T_OFF_MIN SCM_T_INT64_MIN\n");
|
||||
#elif SIZEOF_OFF_T == SIZEOF_INT
|
||||
pf ("typedef int scm_t_off;\n");
|
||||
pf ("#define SCM_T_OFF_MAX INT_MAX\n");
|
||||
pf ("#define SCM_T_OFF_MIN INT_MIN\n");
|
||||
#else
|
||||
pf ("typedef long int scm_t_off;\n");
|
||||
pf ("#define SCM_T_OFF_MAX LONG_MAX\n");
|
||||
pf ("#define SCM_T_OFF_MIN LONG_MIN\n");
|
||||
#endif
|
||||
|
||||
pf ("/* Define to 1 if the compiler supports the "
|
||||
|
|
|
|||
|
|
@ -1373,7 +1373,7 @@ SCM_DEFINE (scm_locale_string_to_integer, "locale-string->integer",
|
|||
|
||||
if (c_locale != NULL)
|
||||
{
|
||||
#ifdef USE_GNU_LOCALE_API
|
||||
#if defined(USE_GNU_LOCALE_API) && defined(HAVE_STRTOL_L)
|
||||
c_result = strtol_l (c_str, &c_endptr, c_base, c_locale);
|
||||
#else
|
||||
RUN_IN_LOCALE_SECTION (c_locale,
|
||||
|
|
|
|||
|
|
@ -1,129 +0,0 @@
|
|||
/* Copyright (C) 1991, 1992, 1996, 1998, 2001, 2006, 2013,
|
||||
2014 Free Software Foundation, Inc.
|
||||
|
||||
This file is derived from mkstemps.c from the GNU Libiberty Library
|
||||
which in turn is derived from the GNU C Library.
|
||||
|
||||
The GNU C Library is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU Library General Public License as
|
||||
published by the Free Software Foundation; either version 2 of the
|
||||
License, or (at your option) any later version.
|
||||
|
||||
The GNU C 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
|
||||
Library General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU Library General Public
|
||||
License along with the GNU C Library; see the file COPYING.LIB. If not,
|
||||
write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
||||
Boston, MA 02110-1301, USA.
|
||||
*/
|
||||
|
||||
#ifdef HAVE_CONFIG_H
|
||||
# include <config.h>
|
||||
#endif
|
||||
|
||||
#include "libguile/__scm.h"
|
||||
|
||||
#ifdef HAVE_STDLIB_H
|
||||
#include <stdlib.h>
|
||||
#endif
|
||||
#ifdef HAVE_STRING_H
|
||||
#include <string.h>
|
||||
#endif
|
||||
#include <errno.h>
|
||||
#include <stdio.h>
|
||||
#include <fcntl.h>
|
||||
#include <unistd.h>
|
||||
#ifdef HAVE_SYS_TIME_H
|
||||
#include <sys/time.h>
|
||||
#endif
|
||||
#ifdef __MINGW32__
|
||||
#include <process.h>
|
||||
#endif
|
||||
|
||||
#ifndef TMP_MAX
|
||||
#define TMP_MAX 16384
|
||||
#endif
|
||||
|
||||
/* We provide this prototype to avoid compiler warnings. If this ever
|
||||
conflicts with a declaration in a system header file, we'll find
|
||||
out, because we should include that header file here. */
|
||||
int mkstemp (char *);
|
||||
|
||||
/* Generate a unique temporary file name from TEMPLATE.
|
||||
|
||||
TEMPLATE has the form:
|
||||
|
||||
<path>/ccXXXXXX
|
||||
|
||||
The last six characters of TEMPLATE must be "XXXXXX"; they are
|
||||
replaced with a string that makes the filename unique.
|
||||
|
||||
Returns a file descriptor open on the file for reading and writing. */
|
||||
int
|
||||
mkstemp (template)
|
||||
char *template;
|
||||
{
|
||||
static const char letters[]
|
||||
= "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789";
|
||||
static scm_t_uint64 value;
|
||||
#ifdef HAVE_GETTIMEOFDAY
|
||||
struct timeval tv;
|
||||
#endif
|
||||
char *XXXXXX;
|
||||
size_t len;
|
||||
int count;
|
||||
|
||||
len = strlen (template);
|
||||
|
||||
if ((int) len < 6
|
||||
|| strncmp (&template[len - 6], "XXXXXX", 6))
|
||||
{
|
||||
return -1;
|
||||
}
|
||||
|
||||
XXXXXX = &template[len - 6];
|
||||
|
||||
#ifdef HAVE_GETTIMEOFDAY
|
||||
/* Get some more or less random data. */
|
||||
gettimeofday (&tv, NULL);
|
||||
value += ((scm_t_uint64) tv.tv_usec << 16) ^ tv.tv_sec ^ getpid ();
|
||||
#else
|
||||
value += getpid ();
|
||||
#endif
|
||||
|
||||
for (count = 0; count < TMP_MAX; ++count)
|
||||
{
|
||||
scm_t_uint64 v = value;
|
||||
int fd;
|
||||
|
||||
/* Fill in the random bits. */
|
||||
XXXXXX[0] = letters[v % 62];
|
||||
v /= 62;
|
||||
XXXXXX[1] = letters[v % 62];
|
||||
v /= 62;
|
||||
XXXXXX[2] = letters[v % 62];
|
||||
v /= 62;
|
||||
XXXXXX[3] = letters[v % 62];
|
||||
v /= 62;
|
||||
XXXXXX[4] = letters[v % 62];
|
||||
v /= 62;
|
||||
XXXXXX[5] = letters[v % 62];
|
||||
|
||||
fd = open (template, O_RDWR|O_CREAT|O_EXCL|O_BINARY, 0600);
|
||||
if (fd >= 0)
|
||||
/* The file does not exist. */
|
||||
return fd;
|
||||
|
||||
/* This is a random value. It is only necessary that the next
|
||||
TMP_MAX values generated by adding 7777 to VALUE are different
|
||||
with (module 2^32). */
|
||||
value += 7777;
|
||||
}
|
||||
|
||||
/* We return the null string if we can't find a unique file name. */
|
||||
template[0] = '\0';
|
||||
return -1;
|
||||
}
|
||||
|
|
@ -1,6 +1,4 @@
|
|||
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
|
||||
* 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012,
|
||||
* 2013, 2014 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 1995-2015 Free Software Foundation, Inc.
|
||||
*
|
||||
* Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
|
||||
* and Bellcore. See scm_divide.
|
||||
|
|
@ -1173,9 +1171,9 @@ void
|
|||
scm_euclidean_divide (SCM x, SCM y, SCM *qp, SCM *rp)
|
||||
{
|
||||
if (scm_is_false (scm_negative_p (y)))
|
||||
return scm_floor_divide (x, y, qp, rp);
|
||||
scm_floor_divide (x, y, qp, rp);
|
||||
else
|
||||
return scm_ceiling_divide (x, y, qp, rp);
|
||||
scm_ceiling_divide (x, y, qp, rp);
|
||||
}
|
||||
|
||||
static SCM scm_i_inexact_floor_quotient (double x, double y);
|
||||
|
|
@ -1549,7 +1547,6 @@ scm_floor_divide (SCM x, SCM y, SCM *qp, SCM *rp)
|
|||
*qp = scm_i_inum2big (qq);
|
||||
*rp = SCM_I_MAKINUM (rr);
|
||||
}
|
||||
return;
|
||||
}
|
||||
else if (SCM_BIGP (y))
|
||||
{
|
||||
|
|
@ -1584,15 +1581,14 @@ scm_floor_divide (SCM x, SCM y, SCM *qp, SCM *rp)
|
|||
*qp = SCM_I_MAKINUM (-1);
|
||||
*rp = scm_i_normbig (r);
|
||||
}
|
||||
return;
|
||||
}
|
||||
else if (SCM_REALP (y))
|
||||
return scm_i_inexact_floor_divide (xx, SCM_REAL_VALUE (y), qp, rp);
|
||||
scm_i_inexact_floor_divide (xx, SCM_REAL_VALUE (y), qp, rp);
|
||||
else if (SCM_FRACTIONP (y))
|
||||
return scm_i_exact_rational_floor_divide (x, y, qp, rp);
|
||||
scm_i_exact_rational_floor_divide (x, y, qp, rp);
|
||||
else
|
||||
return two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2,
|
||||
s_scm_floor_divide, qp, rp);
|
||||
two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2,
|
||||
s_scm_floor_divide, qp, rp);
|
||||
}
|
||||
else if (SCM_BIGP (x))
|
||||
{
|
||||
|
|
@ -1618,7 +1614,6 @@ scm_floor_divide (SCM x, SCM y, SCM *qp, SCM *rp)
|
|||
*qp = scm_i_normbig (q);
|
||||
*rp = scm_i_normbig (r);
|
||||
}
|
||||
return;
|
||||
}
|
||||
else if (SCM_BIGP (y))
|
||||
{
|
||||
|
|
@ -1629,41 +1624,40 @@ scm_floor_divide (SCM x, SCM y, SCM *qp, SCM *rp)
|
|||
scm_remember_upto_here_2 (x, y);
|
||||
*qp = scm_i_normbig (q);
|
||||
*rp = scm_i_normbig (r);
|
||||
return;
|
||||
}
|
||||
else if (SCM_REALP (y))
|
||||
return scm_i_inexact_floor_divide
|
||||
(scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp);
|
||||
scm_i_inexact_floor_divide (scm_i_big2dbl (x), SCM_REAL_VALUE (y),
|
||||
qp, rp);
|
||||
else if (SCM_FRACTIONP (y))
|
||||
return scm_i_exact_rational_floor_divide (x, y, qp, rp);
|
||||
scm_i_exact_rational_floor_divide (x, y, qp, rp);
|
||||
else
|
||||
return two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2,
|
||||
s_scm_floor_divide, qp, rp);
|
||||
two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2,
|
||||
s_scm_floor_divide, qp, rp);
|
||||
}
|
||||
else if (SCM_REALP (x))
|
||||
{
|
||||
if (SCM_REALP (y) || SCM_I_INUMP (y) ||
|
||||
SCM_BIGP (y) || SCM_FRACTIONP (y))
|
||||
return scm_i_inexact_floor_divide
|
||||
(SCM_REAL_VALUE (x), scm_to_double (y), qp, rp);
|
||||
scm_i_inexact_floor_divide (SCM_REAL_VALUE (x), scm_to_double (y),
|
||||
qp, rp);
|
||||
else
|
||||
return two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2,
|
||||
s_scm_floor_divide, qp, rp);
|
||||
two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2,
|
||||
s_scm_floor_divide, qp, rp);
|
||||
}
|
||||
else if (SCM_FRACTIONP (x))
|
||||
{
|
||||
if (SCM_REALP (y))
|
||||
return scm_i_inexact_floor_divide
|
||||
(scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
|
||||
scm_i_inexact_floor_divide
|
||||
(scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
|
||||
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
|
||||
return scm_i_exact_rational_floor_divide (x, y, qp, rp);
|
||||
scm_i_exact_rational_floor_divide (x, y, qp, rp);
|
||||
else
|
||||
return two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2,
|
||||
s_scm_floor_divide, qp, rp);
|
||||
two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2,
|
||||
s_scm_floor_divide, qp, rp);
|
||||
}
|
||||
else
|
||||
return two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG1,
|
||||
s_scm_floor_divide, qp, rp);
|
||||
two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG1,
|
||||
s_scm_floor_divide, qp, rp);
|
||||
}
|
||||
|
||||
static void
|
||||
|
|
@ -2090,7 +2084,6 @@ scm_ceiling_divide (SCM x, SCM y, SCM *qp, SCM *rp)
|
|||
*qp = scm_i_inum2big (qq);
|
||||
*rp = SCM_I_MAKINUM (rr);
|
||||
}
|
||||
return;
|
||||
}
|
||||
else if (SCM_BIGP (y))
|
||||
{
|
||||
|
|
@ -2136,15 +2129,14 @@ scm_ceiling_divide (SCM x, SCM y, SCM *qp, SCM *rp)
|
|||
*qp = SCM_INUM1;
|
||||
*rp = scm_i_normbig (r);
|
||||
}
|
||||
return;
|
||||
}
|
||||
else if (SCM_REALP (y))
|
||||
return scm_i_inexact_ceiling_divide (xx, SCM_REAL_VALUE (y), qp, rp);
|
||||
scm_i_inexact_ceiling_divide (xx, SCM_REAL_VALUE (y), qp, rp);
|
||||
else if (SCM_FRACTIONP (y))
|
||||
return scm_i_exact_rational_ceiling_divide (x, y, qp, rp);
|
||||
scm_i_exact_rational_ceiling_divide (x, y, qp, rp);
|
||||
else
|
||||
return two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
|
||||
s_scm_ceiling_divide, qp, rp);
|
||||
two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
|
||||
s_scm_ceiling_divide, qp, rp);
|
||||
}
|
||||
else if (SCM_BIGP (x))
|
||||
{
|
||||
|
|
@ -2170,7 +2162,6 @@ scm_ceiling_divide (SCM x, SCM y, SCM *qp, SCM *rp)
|
|||
*qp = scm_i_normbig (q);
|
||||
*rp = scm_i_normbig (r);
|
||||
}
|
||||
return;
|
||||
}
|
||||
else if (SCM_BIGP (y))
|
||||
{
|
||||
|
|
@ -2181,41 +2172,40 @@ scm_ceiling_divide (SCM x, SCM y, SCM *qp, SCM *rp)
|
|||
scm_remember_upto_here_2 (x, y);
|
||||
*qp = scm_i_normbig (q);
|
||||
*rp = scm_i_normbig (r);
|
||||
return;
|
||||
}
|
||||
else if (SCM_REALP (y))
|
||||
return scm_i_inexact_ceiling_divide
|
||||
(scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp);
|
||||
scm_i_inexact_ceiling_divide (scm_i_big2dbl (x), SCM_REAL_VALUE (y),
|
||||
qp, rp);
|
||||
else if (SCM_FRACTIONP (y))
|
||||
return scm_i_exact_rational_ceiling_divide (x, y, qp, rp);
|
||||
scm_i_exact_rational_ceiling_divide (x, y, qp, rp);
|
||||
else
|
||||
return two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
|
||||
s_scm_ceiling_divide, qp, rp);
|
||||
two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
|
||||
s_scm_ceiling_divide, qp, rp);
|
||||
}
|
||||
else if (SCM_REALP (x))
|
||||
{
|
||||
if (SCM_REALP (y) || SCM_I_INUMP (y) ||
|
||||
SCM_BIGP (y) || SCM_FRACTIONP (y))
|
||||
return scm_i_inexact_ceiling_divide
|
||||
(SCM_REAL_VALUE (x), scm_to_double (y), qp, rp);
|
||||
scm_i_inexact_ceiling_divide (SCM_REAL_VALUE (x), scm_to_double (y),
|
||||
qp, rp);
|
||||
else
|
||||
return two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
|
||||
s_scm_ceiling_divide, qp, rp);
|
||||
two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
|
||||
s_scm_ceiling_divide, qp, rp);
|
||||
}
|
||||
else if (SCM_FRACTIONP (x))
|
||||
{
|
||||
if (SCM_REALP (y))
|
||||
return scm_i_inexact_ceiling_divide
|
||||
scm_i_inexact_ceiling_divide
|
||||
(scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
|
||||
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
|
||||
return scm_i_exact_rational_ceiling_divide (x, y, qp, rp);
|
||||
scm_i_exact_rational_ceiling_divide (x, y, qp, rp);
|
||||
else
|
||||
return two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
|
||||
s_scm_ceiling_divide, qp, rp);
|
||||
two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
|
||||
s_scm_ceiling_divide, qp, rp);
|
||||
}
|
||||
else
|
||||
return two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG1,
|
||||
s_scm_ceiling_divide, qp, rp);
|
||||
two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG1,
|
||||
s_scm_ceiling_divide, qp, rp);
|
||||
}
|
||||
|
||||
static void
|
||||
|
|
@ -2573,7 +2563,6 @@ scm_truncate_divide (SCM x, SCM y, SCM *qp, SCM *rp)
|
|||
*qp = scm_i_inum2big (qq);
|
||||
*rp = SCM_I_MAKINUM (rr);
|
||||
}
|
||||
return;
|
||||
}
|
||||
else if (SCM_BIGP (y))
|
||||
{
|
||||
|
|
@ -2591,16 +2580,14 @@ scm_truncate_divide (SCM x, SCM y, SCM *qp, SCM *rp)
|
|||
*qp = SCM_INUM0;
|
||||
*rp = x;
|
||||
}
|
||||
return;
|
||||
}
|
||||
else if (SCM_REALP (y))
|
||||
return scm_i_inexact_truncate_divide (xx, SCM_REAL_VALUE (y), qp, rp);
|
||||
scm_i_inexact_truncate_divide (xx, SCM_REAL_VALUE (y), qp, rp);
|
||||
else if (SCM_FRACTIONP (y))
|
||||
return scm_i_exact_rational_truncate_divide (x, y, qp, rp);
|
||||
scm_i_exact_rational_truncate_divide (x, y, qp, rp);
|
||||
else
|
||||
return two_valued_wta_dispatch_2
|
||||
(g_scm_truncate_divide, x, y, SCM_ARG2,
|
||||
s_scm_truncate_divide, qp, rp);
|
||||
two_valued_wta_dispatch_2 (g_scm_truncate_divide, x, y, SCM_ARG2,
|
||||
s_scm_truncate_divide, qp, rp);
|
||||
}
|
||||
else if (SCM_BIGP (x))
|
||||
{
|
||||
|
|
@ -2627,7 +2614,6 @@ scm_truncate_divide (SCM x, SCM y, SCM *qp, SCM *rp)
|
|||
*qp = scm_i_normbig (q);
|
||||
*rp = SCM_I_MAKINUM (rr);
|
||||
}
|
||||
return;
|
||||
}
|
||||
else if (SCM_BIGP (y))
|
||||
{
|
||||
|
|
@ -2640,41 +2626,38 @@ scm_truncate_divide (SCM x, SCM y, SCM *qp, SCM *rp)
|
|||
*rp = scm_i_normbig (r);
|
||||
}
|
||||
else if (SCM_REALP (y))
|
||||
return scm_i_inexact_truncate_divide
|
||||
(scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp);
|
||||
scm_i_inexact_truncate_divide (scm_i_big2dbl (x), SCM_REAL_VALUE (y),
|
||||
qp, rp);
|
||||
else if (SCM_FRACTIONP (y))
|
||||
return scm_i_exact_rational_truncate_divide (x, y, qp, rp);
|
||||
scm_i_exact_rational_truncate_divide (x, y, qp, rp);
|
||||
else
|
||||
return two_valued_wta_dispatch_2
|
||||
(g_scm_truncate_divide, x, y, SCM_ARG2,
|
||||
s_scm_truncate_divide, qp, rp);
|
||||
two_valued_wta_dispatch_2 (g_scm_truncate_divide, x, y, SCM_ARG2,
|
||||
s_scm_truncate_divide, qp, rp);
|
||||
}
|
||||
else if (SCM_REALP (x))
|
||||
{
|
||||
if (SCM_REALP (y) || SCM_I_INUMP (y) ||
|
||||
SCM_BIGP (y) || SCM_FRACTIONP (y))
|
||||
return scm_i_inexact_truncate_divide
|
||||
(SCM_REAL_VALUE (x), scm_to_double (y), qp, rp);
|
||||
scm_i_inexact_truncate_divide (SCM_REAL_VALUE (x), scm_to_double (y),
|
||||
qp, rp);
|
||||
else
|
||||
return two_valued_wta_dispatch_2
|
||||
(g_scm_truncate_divide, x, y, SCM_ARG2,
|
||||
s_scm_truncate_divide, qp, rp);
|
||||
two_valued_wta_dispatch_2 (g_scm_truncate_divide, x, y, SCM_ARG2,
|
||||
s_scm_truncate_divide, qp, rp);
|
||||
}
|
||||
else if (SCM_FRACTIONP (x))
|
||||
{
|
||||
if (SCM_REALP (y))
|
||||
return scm_i_inexact_truncate_divide
|
||||
scm_i_inexact_truncate_divide
|
||||
(scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
|
||||
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
|
||||
return scm_i_exact_rational_truncate_divide (x, y, qp, rp);
|
||||
scm_i_exact_rational_truncate_divide (x, y, qp, rp);
|
||||
else
|
||||
return two_valued_wta_dispatch_2
|
||||
(g_scm_truncate_divide, x, y, SCM_ARG2,
|
||||
s_scm_truncate_divide, qp, rp);
|
||||
two_valued_wta_dispatch_2 (g_scm_truncate_divide, x, y, SCM_ARG2,
|
||||
s_scm_truncate_divide, qp, rp);
|
||||
}
|
||||
else
|
||||
return two_valued_wta_dispatch_2 (g_scm_truncate_divide, x, y, SCM_ARG1,
|
||||
s_scm_truncate_divide, qp, rp);
|
||||
two_valued_wta_dispatch_2 (g_scm_truncate_divide, x, y, SCM_ARG1,
|
||||
s_scm_truncate_divide, qp, rp);
|
||||
}
|
||||
|
||||
static void
|
||||
|
|
@ -3217,22 +3200,18 @@ scm_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp)
|
|||
*qp = scm_i_inum2big (qq);
|
||||
*rp = SCM_I_MAKINUM (rr);
|
||||
}
|
||||
return;
|
||||
}
|
||||
else if (SCM_BIGP (y))
|
||||
{
|
||||
/* Pass a denormalized bignum version of x (even though it
|
||||
can fit in a fixnum) to scm_i_bigint_centered_divide */
|
||||
return scm_i_bigint_centered_divide (scm_i_long2big (xx), y, qp, rp);
|
||||
}
|
||||
/* Pass a denormalized bignum version of x (even though it
|
||||
can fit in a fixnum) to scm_i_bigint_centered_divide */
|
||||
scm_i_bigint_centered_divide (scm_i_long2big (xx), y, qp, rp);
|
||||
else if (SCM_REALP (y))
|
||||
return scm_i_inexact_centered_divide (xx, SCM_REAL_VALUE (y), qp, rp);
|
||||
scm_i_inexact_centered_divide (xx, SCM_REAL_VALUE (y), qp, rp);
|
||||
else if (SCM_FRACTIONP (y))
|
||||
return scm_i_exact_rational_centered_divide (x, y, qp, rp);
|
||||
scm_i_exact_rational_centered_divide (x, y, qp, rp);
|
||||
else
|
||||
return two_valued_wta_dispatch_2
|
||||
(g_scm_centered_divide, x, y, SCM_ARG2,
|
||||
s_scm_centered_divide, qp, rp);
|
||||
two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG2,
|
||||
s_scm_centered_divide, qp, rp);
|
||||
}
|
||||
else if (SCM_BIGP (x))
|
||||
{
|
||||
|
|
@ -3276,46 +3255,42 @@ scm_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp)
|
|||
*qp = scm_i_normbig (q);
|
||||
*rp = SCM_I_MAKINUM (rr);
|
||||
}
|
||||
return;
|
||||
}
|
||||
else if (SCM_BIGP (y))
|
||||
return scm_i_bigint_centered_divide (x, y, qp, rp);
|
||||
scm_i_bigint_centered_divide (x, y, qp, rp);
|
||||
else if (SCM_REALP (y))
|
||||
return scm_i_inexact_centered_divide
|
||||
(scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp);
|
||||
scm_i_inexact_centered_divide (scm_i_big2dbl (x), SCM_REAL_VALUE (y),
|
||||
qp, rp);
|
||||
else if (SCM_FRACTIONP (y))
|
||||
return scm_i_exact_rational_centered_divide (x, y, qp, rp);
|
||||
scm_i_exact_rational_centered_divide (x, y, qp, rp);
|
||||
else
|
||||
return two_valued_wta_dispatch_2
|
||||
(g_scm_centered_divide, x, y, SCM_ARG2,
|
||||
s_scm_centered_divide, qp, rp);
|
||||
two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG2,
|
||||
s_scm_centered_divide, qp, rp);
|
||||
}
|
||||
else if (SCM_REALP (x))
|
||||
{
|
||||
if (SCM_REALP (y) || SCM_I_INUMP (y) ||
|
||||
SCM_BIGP (y) || SCM_FRACTIONP (y))
|
||||
return scm_i_inexact_centered_divide
|
||||
(SCM_REAL_VALUE (x), scm_to_double (y), qp, rp);
|
||||
scm_i_inexact_centered_divide (SCM_REAL_VALUE (x), scm_to_double (y),
|
||||
qp, rp);
|
||||
else
|
||||
return two_valued_wta_dispatch_2
|
||||
(g_scm_centered_divide, x, y, SCM_ARG2,
|
||||
s_scm_centered_divide, qp, rp);
|
||||
two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG2,
|
||||
s_scm_centered_divide, qp, rp);
|
||||
}
|
||||
else if (SCM_FRACTIONP (x))
|
||||
{
|
||||
if (SCM_REALP (y))
|
||||
return scm_i_inexact_centered_divide
|
||||
(scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
|
||||
scm_i_inexact_centered_divide
|
||||
(scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
|
||||
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
|
||||
return scm_i_exact_rational_centered_divide (x, y, qp, rp);
|
||||
scm_i_exact_rational_centered_divide (x, y, qp, rp);
|
||||
else
|
||||
return two_valued_wta_dispatch_2
|
||||
(g_scm_centered_divide, x, y, SCM_ARG2,
|
||||
s_scm_centered_divide, qp, rp);
|
||||
two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG2,
|
||||
s_scm_centered_divide, qp, rp);
|
||||
}
|
||||
else
|
||||
return two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG1,
|
||||
s_scm_centered_divide, qp, rp);
|
||||
two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG1,
|
||||
s_scm_centered_divide, qp, rp);
|
||||
}
|
||||
|
||||
static void
|
||||
|
|
@ -3897,22 +3872,18 @@ scm_round_divide (SCM x, SCM y, SCM *qp, SCM *rp)
|
|||
*qp = scm_i_inum2big (qq);
|
||||
*rp = SCM_I_MAKINUM (rr);
|
||||
}
|
||||
return;
|
||||
}
|
||||
else if (SCM_BIGP (y))
|
||||
{
|
||||
/* Pass a denormalized bignum version of x (even though it
|
||||
can fit in a fixnum) to scm_i_bigint_round_divide */
|
||||
return scm_i_bigint_round_divide
|
||||
(scm_i_long2big (SCM_I_INUM (x)), y, qp, rp);
|
||||
}
|
||||
/* Pass a denormalized bignum version of x (even though it
|
||||
can fit in a fixnum) to scm_i_bigint_round_divide */
|
||||
scm_i_bigint_round_divide (scm_i_long2big (SCM_I_INUM (x)), y, qp, rp);
|
||||
else if (SCM_REALP (y))
|
||||
return scm_i_inexact_round_divide (xx, SCM_REAL_VALUE (y), qp, rp);
|
||||
scm_i_inexact_round_divide (xx, SCM_REAL_VALUE (y), qp, rp);
|
||||
else if (SCM_FRACTIONP (y))
|
||||
return scm_i_exact_rational_round_divide (x, y, qp, rp);
|
||||
scm_i_exact_rational_round_divide (x, y, qp, rp);
|
||||
else
|
||||
return two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2,
|
||||
s_scm_round_divide, qp, rp);
|
||||
two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2,
|
||||
s_scm_round_divide, qp, rp);
|
||||
}
|
||||
else if (SCM_BIGP (x))
|
||||
{
|
||||
|
|
@ -3955,43 +3926,42 @@ scm_round_divide (SCM x, SCM y, SCM *qp, SCM *rp)
|
|||
*qp = scm_i_normbig (q);
|
||||
*rp = SCM_I_MAKINUM (rr);
|
||||
}
|
||||
return;
|
||||
}
|
||||
else if (SCM_BIGP (y))
|
||||
return scm_i_bigint_round_divide (x, y, qp, rp);
|
||||
scm_i_bigint_round_divide (x, y, qp, rp);
|
||||
else if (SCM_REALP (y))
|
||||
return scm_i_inexact_round_divide
|
||||
(scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp);
|
||||
scm_i_inexact_round_divide (scm_i_big2dbl (x), SCM_REAL_VALUE (y),
|
||||
qp, rp);
|
||||
else if (SCM_FRACTIONP (y))
|
||||
return scm_i_exact_rational_round_divide (x, y, qp, rp);
|
||||
scm_i_exact_rational_round_divide (x, y, qp, rp);
|
||||
else
|
||||
return two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2,
|
||||
s_scm_round_divide, qp, rp);
|
||||
two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2,
|
||||
s_scm_round_divide, qp, rp);
|
||||
}
|
||||
else if (SCM_REALP (x))
|
||||
{
|
||||
if (SCM_REALP (y) || SCM_I_INUMP (y) ||
|
||||
SCM_BIGP (y) || SCM_FRACTIONP (y))
|
||||
return scm_i_inexact_round_divide
|
||||
(SCM_REAL_VALUE (x), scm_to_double (y), qp, rp);
|
||||
scm_i_inexact_round_divide (SCM_REAL_VALUE (x), scm_to_double (y),
|
||||
qp, rp);
|
||||
else
|
||||
return two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2,
|
||||
s_scm_round_divide, qp, rp);
|
||||
two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2,
|
||||
s_scm_round_divide, qp, rp);
|
||||
}
|
||||
else if (SCM_FRACTIONP (x))
|
||||
{
|
||||
if (SCM_REALP (y))
|
||||
return scm_i_inexact_round_divide
|
||||
scm_i_inexact_round_divide
|
||||
(scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
|
||||
else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
|
||||
return scm_i_exact_rational_round_divide (x, y, qp, rp);
|
||||
scm_i_exact_rational_round_divide (x, y, qp, rp);
|
||||
else
|
||||
return two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2,
|
||||
s_scm_round_divide, qp, rp);
|
||||
two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2,
|
||||
s_scm_round_divide, qp, rp);
|
||||
}
|
||||
else
|
||||
return two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG1,
|
||||
s_scm_round_divide, qp, rp);
|
||||
two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG1,
|
||||
s_scm_round_divide, qp, rp);
|
||||
}
|
||||
|
||||
static void
|
||||
|
|
@ -9023,8 +8993,8 @@ SCM_PRIMITIVE_GENERIC (scm_atan, "atan", 1, 1, 0,
|
|||
double v, w;
|
||||
v = SCM_COMPLEX_REAL (z);
|
||||
w = SCM_COMPLEX_IMAG (z);
|
||||
return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v, w - 1.0),
|
||||
scm_c_make_rectangular (v, w + 1.0))),
|
||||
return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (-v, 1.0 - w),
|
||||
scm_c_make_rectangular ( v, 1.0 + w))),
|
||||
scm_c_make_rectangular (0, 2));
|
||||
}
|
||||
else
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
/* Copyright (C) 1995-1997, 1999-2001, 2003, 2004, 2006-2012, 2014
|
||||
/* Copyright (C) 1995-1997, 1999-2001, 2003, 2004, 2006-2012, 2014, 2015
|
||||
* Free Software Foundation, Inc.
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or
|
||||
|
|
@ -1430,6 +1430,12 @@ 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 void set_port_r6rs_hex_escapes_p (SCM port, scm_t_read_opts *opts,
|
||||
int value);
|
||||
static void set_port_hungry_eol_escapes_p (SCM port, scm_t_read_opts *opts,
|
||||
int value);
|
||||
static void set_port_keyword_style (SCM port, scm_t_read_opts *opts,
|
||||
enum t_keyword_style value);
|
||||
|
||||
static SCM
|
||||
scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
|
||||
|
|
@ -1451,7 +1457,13 @@ scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
|
|||
scm_ungetc (c, port);
|
||||
name[i] = '\0';
|
||||
if (0 == strcmp ("r6rs", name))
|
||||
; /* Silently ignore */
|
||||
{
|
||||
set_port_case_insensitive_p (port, opts, 0);
|
||||
set_port_r6rs_hex_escapes_p (port, opts, 1);
|
||||
set_port_square_brackets_p (port, opts, 1);
|
||||
set_port_keyword_style (port, opts, KEYWORD_STYLE_HASH_PREFIX);
|
||||
set_port_hungry_eol_escapes_p (port, opts, 1);
|
||||
}
|
||||
else if (0 == strcmp ("fold-case", name))
|
||||
set_port_case_insensitive_p (port, opts, 1);
|
||||
else if (0 == strcmp ("no-fold-case", name))
|
||||
|
|
@ -2299,6 +2311,30 @@ set_port_curly_infix_p (SCM port, scm_t_read_opts *opts, int value)
|
|||
set_port_read_option (port, READ_OPTION_CURLY_INFIX_P, value);
|
||||
}
|
||||
|
||||
/* Set OPTS and PORT's r6rs_hex_escapes_p option according to VALUE. */
|
||||
static void
|
||||
set_port_r6rs_hex_escapes_p (SCM port, scm_t_read_opts *opts, int value)
|
||||
{
|
||||
value = !!value;
|
||||
opts->r6rs_escapes_p = value;
|
||||
set_port_read_option (port, READ_OPTION_R6RS_ESCAPES_P, value);
|
||||
}
|
||||
|
||||
static void
|
||||
set_port_hungry_eol_escapes_p (SCM port, scm_t_read_opts *opts, int value)
|
||||
{
|
||||
value = !!value;
|
||||
opts->hungry_eol_escapes_p = value;
|
||||
set_port_read_option (port, READ_OPTION_HUNGRY_EOL_ESCAPES_P, value);
|
||||
}
|
||||
|
||||
static void
|
||||
set_port_keyword_style (SCM port, scm_t_read_opts *opts, enum t_keyword_style value)
|
||||
{
|
||||
opts->keyword_style = value;
|
||||
set_port_read_option (port, READ_OPTION_KEYWORD_STYLE, value);
|
||||
}
|
||||
|
||||
/* Initialize OPTS based on PORT's read options and the global read
|
||||
options. */
|
||||
static void
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
/* Copyright (C) 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005,
|
||||
* 2006, 2007, 2009, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 1996-1998, 2000-2007, 2009, 2011-2015
|
||||
* 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
|
||||
|
|
@ -508,19 +508,7 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0,
|
|||
scm_from_int (0));
|
||||
#endif
|
||||
}
|
||||
else
|
||||
#endif
|
||||
if (0
|
||||
#ifdef SO_SNDBUF
|
||||
|| ioptname == SO_SNDBUF
|
||||
#endif
|
||||
#ifdef SO_RCVBUF
|
||||
|| ioptname == SO_RCVBUF
|
||||
#endif
|
||||
)
|
||||
{
|
||||
return scm_from_size_t (*(size_t *) &optval);
|
||||
}
|
||||
}
|
||||
return scm_from_int (*(int *) &optval);
|
||||
}
|
||||
|
|
@ -649,21 +637,7 @@ SCM_DEFINE (scm_setsockopt, "setsockopt", 4, 0, 0,
|
|||
optval = &opt_int;
|
||||
#endif
|
||||
}
|
||||
else
|
||||
#endif
|
||||
if (0
|
||||
#ifdef SO_SNDBUF
|
||||
|| ioptname == SO_SNDBUF
|
||||
#endif
|
||||
#ifdef SO_RCVBUF
|
||||
|| ioptname == SO_RCVBUF
|
||||
#endif
|
||||
)
|
||||
{
|
||||
opt_int = scm_to_int (value);
|
||||
optlen = sizeof (size_t);
|
||||
optval = &opt_int;
|
||||
}
|
||||
}
|
||||
|
||||
#ifdef HAVE_STRUCT_IP_MREQ
|
||||
|
|
|
|||
1730
libguile/srfi-14.i.c
1730
libguile/srfi-14.i.c
File diff suppressed because it is too large
Load diff
|
|
@ -1,5 +1,5 @@
|
|||
/* Copyright (C) 1995, 1996, 1998, 2000, 2001, 2004, 2006,
|
||||
* 2008-2015 Free Software Foundation, Inc.
|
||||
* 2008-2016 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
|
||||
|
|
@ -2065,6 +2065,38 @@ u32_u8_length_in_bytes (const scm_t_uint32 *str, size_t len)
|
|||
return ret;
|
||||
}
|
||||
|
||||
static size_t
|
||||
utf8_length (SCM str)
|
||||
{
|
||||
if (scm_i_is_narrow_string (str))
|
||||
return latin1_u8_strlen ((scm_t_uint8 *) scm_i_string_chars (str),
|
||||
scm_i_string_length (str));
|
||||
else
|
||||
return u32_u8_length_in_bytes
|
||||
((scm_t_uint32 *) scm_i_string_wide_chars (str),
|
||||
scm_i_string_length (str));
|
||||
}
|
||||
|
||||
size_t
|
||||
scm_c_string_utf8_length (SCM string)
|
||||
#define FUNC_NAME "scm_c_string_utf8_length"
|
||||
{
|
||||
SCM_VALIDATE_STRING (1, string);
|
||||
return utf8_length (string);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_string_utf8_length, "string-utf8-length", 1, 0, 0,
|
||||
(SCM string),
|
||||
"Returns the number of bytes in the UTF-8 representation of "
|
||||
"@var{string}.")
|
||||
#define FUNC_NAME s_scm_string_utf8_length
|
||||
{
|
||||
SCM_VALIDATE_STRING (1, string);
|
||||
return scm_from_size_t (utf8_length (string));
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
char *
|
||||
scm_to_utf8_stringn (SCM str, size_t *lenp)
|
||||
#define FUNC_NAME "scm_to_utf8_stringn"
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
#ifndef SCM_STRINGS_H
|
||||
#define SCM_STRINGS_H
|
||||
|
||||
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2005, 2006, 2008, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 1995-1998, 2000, 2001, 2004-2006, 2008-2011, 2013,
|
||||
* 2015-2016 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
|
||||
|
|
@ -107,6 +108,7 @@ SCM_API SCM scm_string_p (SCM x);
|
|||
SCM_API SCM scm_string (SCM chrs);
|
||||
SCM_API SCM scm_make_string (SCM k, SCM chr);
|
||||
SCM_API SCM scm_string_length (SCM str);
|
||||
SCM_API SCM scm_string_utf8_length (SCM str);
|
||||
SCM_API SCM scm_string_bytes_per_char (SCM str);
|
||||
SCM_API SCM scm_string_ref (SCM str, SCM k);
|
||||
SCM_API SCM scm_string_set_x (SCM str, SCM k, SCM chr);
|
||||
|
|
@ -120,6 +122,7 @@ SCM_API SCM scm_from_stringn (const char *str, size_t len, const char *encoding,
|
|||
scm_t_string_failed_conversion_handler handler);
|
||||
SCM_API SCM scm_c_make_string (size_t len, SCM chr);
|
||||
SCM_API size_t scm_c_string_length (SCM str);
|
||||
SCM_API size_t scm_c_string_utf8_length (SCM str);
|
||||
SCM_API size_t scm_c_symbol_length (SCM sym);
|
||||
SCM_API SCM scm_c_string_ref (SCM str, size_t pos);
|
||||
SCM_API void scm_c_string_set_x (SCM str, size_t pos, SCM chr);
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Parsing Guile's command-line
|
||||
|
||||
;;; Copyright (C) 1994-1998, 2000-2015 Free Software Foundation, Inc.
|
||||
;;; Copyright (C) 1994-1998, 2000-2016 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
|
||||
|
|
@ -66,7 +66,7 @@ There is NO WARRANTY, to the extent permitted by law."))
|
|||
(define* (version-etc package version #:key
|
||||
(port (current-output-port))
|
||||
;; FIXME: authors
|
||||
(copyright-year 2014)
|
||||
(copyright-year 2016)
|
||||
(copyright-holder "Free Software Foundation, Inc.")
|
||||
(copyright (format #f "Copyright (C) ~a ~a"
|
||||
copyright-year copyright-holder))
|
||||
|
|
|
|||
|
|
@ -2509,7 +2509,8 @@
|
|||
(values '() (cdr y-pat) (match (car e) (car y-pat) w r mod)))
|
||||
(values #f #f #f)))))
|
||||
((syntax-object? e)
|
||||
(f (syntax-object-expression e) (join-wraps w e)))
|
||||
(f (syntax-object-expression e)
|
||||
(join-wraps w (syntax-object-wrap e))))
|
||||
(else (values '() y-pat (match e z-pat w r mod)))))))
|
||||
(match-each-any
|
||||
(lambda (e w mod)
|
||||
|
|
|
|||
|
|
@ -2849,7 +2849,8 @@
|
|||
(match (car e) (car y-pat) w r mod)))
|
||||
(values #f #f #f)))))
|
||||
((syntax-object? e)
|
||||
(f (syntax-object-expression e) (join-wraps w e)))
|
||||
(f (syntax-object-expression e)
|
||||
(join-wraps w (syntax-object-wrap e))))
|
||||
(else
|
||||
(values '() y-pat (match e z-pat w r mod)))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
;;; srfi-19.scm --- Time/Date Library
|
||||
|
||||
;; Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008, 2009, 2010,
|
||||
;; 2011, 2014 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2001-2003, 2005-2011, 2014, 2016
|
||||
;; 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
|
||||
|
|
@ -203,7 +203,8 @@
|
|||
;; each entry is (tai seconds since epoch . # seconds to subtract for utc)
|
||||
;; note they go higher to lower, and end in 1972.
|
||||
(define leap-second-table
|
||||
'((1341100800 . 35)
|
||||
'((1435708800 . 36)
|
||||
(1341100800 . 35)
|
||||
(1230768000 . 34)
|
||||
(1136073600 . 33)
|
||||
(915148800 . 32)
|
||||
|
|
|
|||
|
|
@ -117,8 +117,12 @@ SIZE is omitted, return an unbounded port to the memory at ADDRESS."
|
|||
(let ((open (memory-backend-open backend)))
|
||||
(open address #f)))
|
||||
((_ backend address size)
|
||||
(let ((open (memory-backend-open backend)))
|
||||
(open address size)))))
|
||||
(if (zero? size)
|
||||
;; GDB's 'open-memory' raises an error when size
|
||||
;; is zero, so we must handle that case specially.
|
||||
(open-bytevector-input-port '#vu8())
|
||||
(let ((open (memory-backend-open backend)))
|
||||
(open address size))))))
|
||||
|
||||
(define (get-word port)
|
||||
"Read a word from PORT and return it as an integer."
|
||||
|
|
@ -440,7 +444,7 @@ using BACKEND."
|
|||
('big "UTF-32BE")))))
|
||||
(((_ & #x7f = %tc7-bytevector) len address)
|
||||
(let ((bv-port (memory-port backend address len)))
|
||||
(get-bytevector-all bv-port)))
|
||||
(get-bytevector-n bv-port len)))
|
||||
((((len << 8) || %tc7-vector))
|
||||
(let ((words (get-bytevector-n port (* len %word-size)))
|
||||
(vector (make-vector len)))
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
;;; Repl common routines
|
||||
|
||||
;; Copyright (C) 2001, 2008, 2009, 2010, 2011, 2012,
|
||||
;; 2013, 2014 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2001, 2008-2016 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
|
||||
|
|
@ -41,7 +40,7 @@
|
|||
|
||||
(define *version*
|
||||
(format #f "GNU Guile ~A
|
||||
Copyright (C) 1995-2014 Free Software Foundation, Inc.
|
||||
Copyright (C) 1995-2016 Free Software Foundation, Inc.
|
||||
|
||||
Guile comes with ABSOLUTELY NO WARRANTY; for details type `,show w'.
|
||||
This program is free software, and you are welcome to redistribute it
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; HTTP messages
|
||||
|
||||
;; Copyright (C) 2010, 2011, 2012, 2013, 2014, 2016 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2010-2016 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
|
||||
|
|
@ -34,6 +34,7 @@
|
|||
#:use-module (srfi srfi-9)
|
||||
#:use-module (srfi srfi-19)
|
||||
#:use-module (ice-9 rdelim)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 q)
|
||||
#:use-module (ice-9 binary-ports)
|
||||
#:use-module (rnrs bytevectors)
|
||||
|
|
@ -143,28 +144,27 @@ The default writer is ‘display’."
|
|||
(header-decl-writer decl)
|
||||
display)))
|
||||
|
||||
(define (read-line* port)
|
||||
(let* ((pair (%read-line port))
|
||||
(line (car pair))
|
||||
(delim (cdr pair)))
|
||||
(if (and (string? line) (char? delim))
|
||||
(let ((orig-len (string-length line)))
|
||||
(let lp ((len orig-len))
|
||||
(if (and (> len 0)
|
||||
(char-whitespace? (string-ref line (1- len))))
|
||||
(lp (1- len))
|
||||
(if (= len orig-len)
|
||||
line
|
||||
(substring line 0 len)))))
|
||||
(bad-header '%read line))))
|
||||
(define (read-header-line port)
|
||||
"Read an HTTP header line and return it without its final CRLF or LF.
|
||||
Raise a 'bad-header' exception if the line does not end in CRLF or LF,
|
||||
or if EOF is reached."
|
||||
(match (%read-line port)
|
||||
(((? string? line) . #\newline)
|
||||
;; '%read-line' does not consider #\return a delimiter; so if it's
|
||||
;; there, remove it. We are more tolerant than the RFC in that we
|
||||
;; tolerate LF-only endings.
|
||||
(if (string-suffix? "\r" line)
|
||||
(string-drop-right line 1)
|
||||
line))
|
||||
((line . _) ;EOF or missing delimiter
|
||||
(bad-header 'read-header-line line))))
|
||||
|
||||
(define (read-continuation-line port val)
|
||||
(if (or (eqv? (peek-char port) #\space)
|
||||
(eqv? (peek-char port) #\tab))
|
||||
(read-continuation-line port
|
||||
(string-append val
|
||||
(begin
|
||||
(read-line* port))))
|
||||
(read-header-line port)))
|
||||
val))
|
||||
|
||||
(define *eof* (call-with-input-string "" read))
|
||||
|
|
@ -176,7 +176,7 @@ was known but the value was invalid.
|
|||
|
||||
Returns the end-of-file object for both values if the end of the message
|
||||
body was reached (i.e., a blank line)."
|
||||
(let ((line (read-line* port)))
|
||||
(let ((line (read-header-line port)))
|
||||
(if (or (string-null? line)
|
||||
(string=? line "\r"))
|
||||
(values *eof* *eof*)
|
||||
|
|
@ -751,6 +751,26 @@ as an ordered alist."
|
|||
(minute (parse-non-negative-integer str 19 21))
|
||||
(second (parse-non-negative-integer str 22 24)))
|
||||
(make-date 0 second minute hour date month year zone-offset)))
|
||||
|
||||
;; The next two clauses match dates that have a space instead of
|
||||
;; a leading zero for hours, like " 8:49:37".
|
||||
((string-match? (substring str 0 space) "aaa, dd aaa dddd d:dd:dd")
|
||||
(let ((date (parse-non-negative-integer str 5 7))
|
||||
(month (parse-month str 8 11))
|
||||
(year (parse-non-negative-integer str 12 16))
|
||||
(hour (parse-non-negative-integer str 18 19))
|
||||
(minute (parse-non-negative-integer str 20 22))
|
||||
(second (parse-non-negative-integer str 23 25)))
|
||||
(make-date 0 second minute hour date month year zone-offset)))
|
||||
((string-match? (substring str 0 space) "aaa, d aaa dddd d:dd:dd")
|
||||
(let ((date (parse-non-negative-integer str 5 6))
|
||||
(month (parse-month str 7 10))
|
||||
(year (parse-non-negative-integer str 11 15))
|
||||
(hour (parse-non-negative-integer str 17 18))
|
||||
(minute (parse-non-negative-integer str 19 21))
|
||||
(second (parse-non-negative-integer str 22 24)))
|
||||
(make-date 0 second minute hour date month year zone-offset)))
|
||||
|
||||
(else
|
||||
(bad-header 'date str) ; prevent tail call
|
||||
#f)))
|
||||
|
|
@ -1085,7 +1105,7 @@ not have to have a scheme or host name. The result is a URI object."
|
|||
(define (read-request-line port)
|
||||
"Read the first line of an HTTP request from PORT, returning
|
||||
three values: the method, the URI, and the version."
|
||||
(let* ((line (read-line* port))
|
||||
(let* ((line (read-header-line port))
|
||||
(d0 (string-index line char-set:whitespace)) ; "delimiter zero"
|
||||
(d1 (string-rindex line char-set:whitespace)))
|
||||
(if (and d0 d1 (< d0 d1))
|
||||
|
|
@ -1154,10 +1174,10 @@ three values: the method, the URI, and the version."
|
|||
(display "\r\n" port))
|
||||
|
||||
(define (read-response-line port)
|
||||
"Read the first line of an HTTP response from PORT, returning
|
||||
three values: the HTTP version, the response code, and the \"reason
|
||||
phrase\"."
|
||||
(let* ((line (read-line* port))
|
||||
"Read the first line of an HTTP response from PORT, returning three
|
||||
values: the HTTP version, the response code, and the (possibly empty)
|
||||
\"reason phrase\"."
|
||||
(let* ((line (read-header-line port))
|
||||
(d0 (string-index line char-set:whitespace)) ; "delimiter zero"
|
||||
(d1 (and d0 (string-index line char-set:whitespace
|
||||
(skip-whitespace line d0)))))
|
||||
|
|
@ -1914,24 +1934,21 @@ treated specially, and is just returned as a plain string."
|
|||
|
||||
;; Chunked Responses
|
||||
(define (read-chunk-header port)
|
||||
(let* ((str (read-line port))
|
||||
(extension-start (string-index str (lambda (c) (or (char=? c #\;)
|
||||
(char=? c #\return)))))
|
||||
(size (string->number (if extension-start ; unnecessary?
|
||||
(substring str 0 extension-start)
|
||||
str)
|
||||
16)))
|
||||
size))
|
||||
|
||||
(define (read-chunk port)
|
||||
(let ((size (read-chunk-header port)))
|
||||
(read-chunk-body port size)))
|
||||
|
||||
(define (read-chunk-body port size)
|
||||
(let ((bv (get-bytevector-n port size)))
|
||||
(get-u8 port) ; CR
|
||||
(get-u8 port) ; LF
|
||||
bv))
|
||||
"Read a chunk header from PORT and return the size in bytes of the
|
||||
upcoming chunk."
|
||||
(match (read-line port)
|
||||
((? eof-object?)
|
||||
;; Connection closed prematurely: there's nothing left to read.
|
||||
0)
|
||||
(str
|
||||
(let ((extension-start (string-index str
|
||||
(lambda (c)
|
||||
(or (char=? c #\;)
|
||||
(char=? c #\return))))))
|
||||
(string->number (if extension-start ; unnecessary?
|
||||
(substring str 0 extension-start)
|
||||
str)
|
||||
16)))))
|
||||
|
||||
(define* (make-chunked-input-port port #:key (keep-alive? #f))
|
||||
"Returns a new port which translates HTTP chunked transfer encoded
|
||||
|
|
@ -1939,37 +1956,44 @@ data from PORT into a non-encoded format. Returns eof when it has
|
|||
read the final chunk from PORT. This does not necessarily mean
|
||||
that there is no more data on PORT. When the returned port is
|
||||
closed it will also close PORT, unless the KEEP-ALIVE? is true."
|
||||
(define (next-chunk)
|
||||
(read-chunk port))
|
||||
(define finished? #f)
|
||||
(define (close)
|
||||
(unless keep-alive?
|
||||
(close-port port)))
|
||||
(define buffer #vu8())
|
||||
(define buffer-size 0)
|
||||
(define buffer-pointer 0)
|
||||
|
||||
(define chunk-size 0) ;size of the current chunk
|
||||
(define remaining 0) ;number of bytes left from the current chunk
|
||||
(define finished? #f) ;did we get all the chunks?
|
||||
|
||||
(define (read! bv idx to-read)
|
||||
(define (loop to-read num-read)
|
||||
(cond ((or finished? (zero? to-read))
|
||||
num-read)
|
||||
((<= to-read (- buffer-size buffer-pointer))
|
||||
(bytevector-copy! buffer buffer-pointer
|
||||
bv (+ idx num-read)
|
||||
to-read)
|
||||
(set! buffer-pointer (+ buffer-pointer to-read))
|
||||
(loop 0 (+ num-read to-read)))
|
||||
(else
|
||||
(let ((n (- buffer-size buffer-pointer)))
|
||||
(bytevector-copy! buffer buffer-pointer
|
||||
bv (+ idx num-read)
|
||||
n)
|
||||
(set! buffer (next-chunk))
|
||||
(set! buffer-pointer 0)
|
||||
(set! buffer-size (bytevector-length buffer))
|
||||
(set! finished? (= buffer-size 0))
|
||||
(loop (- to-read n)
|
||||
(+ num-read n))))))
|
||||
((zero? remaining) ;get a new chunk
|
||||
(let ((size (read-chunk-header port)))
|
||||
(set! chunk-size size)
|
||||
(set! remaining size)
|
||||
(if (zero? size)
|
||||
(begin
|
||||
(set! finished? #t)
|
||||
num-read)
|
||||
(loop to-read num-read))))
|
||||
(else ;read from the current chunk
|
||||
(let* ((ask-for (min to-read remaining))
|
||||
(read (get-bytevector-n! port bv (+ idx num-read)
|
||||
ask-for)))
|
||||
(if (eof-object? read)
|
||||
(begin ;premature termination
|
||||
(set! finished? #t)
|
||||
num-read)
|
||||
(let ((left (- remaining read)))
|
||||
(set! remaining left)
|
||||
(when (zero? left)
|
||||
;; We're done with this chunk; read CR and LF.
|
||||
(get-u8 port) (get-u8 port))
|
||||
(loop (- to-read read)
|
||||
(+ num-read read))))))))
|
||||
(loop to-read 0))
|
||||
|
||||
(make-custom-binary-input-port "chunked input port" read! #f #f close))
|
||||
|
||||
(define* (make-chunked-output-port port #:key (keep-alive? #f)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; HTTP response objects
|
||||
|
||||
;; Copyright (C) 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2010, 2011, 2012, 2013, 2014, 2015 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
|
||||
|
|
@ -265,7 +265,7 @@ closes PORT, unless KEEP-ALIVE? is true."
|
|||
(define close
|
||||
(and (not keep-alive?)
|
||||
(lambda ()
|
||||
(close port))))
|
||||
(close-port port))))
|
||||
|
||||
(make-custom-binary-input-port "delimited input port" read! #f #f close))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Web server
|
||||
|
||||
;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2010, 2011, 2012, 2013, 2015 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
|
||||
|
|
@ -84,6 +84,15 @@
|
|||
#:use-module (ice-9 iconv)
|
||||
#:export (define-server-impl
|
||||
lookup-server-impl
|
||||
|
||||
make-server-impl
|
||||
server-impl?
|
||||
server-impl-name
|
||||
server-impl-open
|
||||
server-impl-read
|
||||
server-impl-write
|
||||
server-impl-close
|
||||
|
||||
open-server
|
||||
read-client
|
||||
handle-request
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Web I/O: HTTP
|
||||
|
||||
;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2010, 2011, 2012, 2015 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
|
||||
|
|
@ -34,7 +34,8 @@
|
|||
#:use-module (web request)
|
||||
#:use-module (web response)
|
||||
#:use-module (web server)
|
||||
#:use-module (ice-9 poll))
|
||||
#:use-module (ice-9 poll)
|
||||
#:export (http))
|
||||
|
||||
|
||||
(define (make-default-socket family addr port)
|
||||
|
|
|
|||
|
|
@ -10,6 +10,11 @@ trap 'rm -f "$source" "$target"' EXIT
|
|||
|
||||
cat > "$source"<<EOF
|
||||
(eval-when (expand load eval)
|
||||
;; Wait for SIGINT.
|
||||
(pause)
|
||||
|
||||
;; Then sleep so that the SIGINT handler gets to run
|
||||
;; and compilation doesn't complete before it runs.
|
||||
(sleep 100))
|
||||
(define chbouib 42)
|
||||
EOF
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
;;;; i18n.test --- Exercise the i18n API. -*- coding: utf-8; mode: scheme; -*-
|
||||
;;;;
|
||||
;;;; Copyright (C) 2006, 2007, 2009, 2010, 2011, 2012,
|
||||
;;;; 2013, 2014 Free Software Foundation, Inc.
|
||||
;;;; 2013, 2014, 2015 Free Software Foundation, Inc.
|
||||
;;;; Ludovic Courtès
|
||||
;;;;
|
||||
;;;; This library is free software; you can redistribute it and/or
|
||||
|
|
@ -270,6 +270,23 @@
|
|||
(let ((gr (make-locale LC_ALL %greek-utf8-locale-name)))
|
||||
(string-locale-ci=? "ΧΑΟΣ" "χαος" gr))))))
|
||||
|
||||
|
||||
(with-test-prefix "text collation (Czech)"
|
||||
|
||||
(pass-if "string-locale<? for 'ch'"
|
||||
(under-locale-or-unresolved
|
||||
"cs_CZ.utf8"
|
||||
(lambda ()
|
||||
;; Czech sorts digraph 'ch' between 'h' and 'i'.
|
||||
;;
|
||||
;; GNU libc 2.22 gets this wrong:
|
||||
;; <https://sourceware.org/bugzilla/show_bug.cgi?id=18589>. For
|
||||
;; now, just skip it if it fails (XXX).
|
||||
(or (and (string-locale>? "chxxx" "cxxx")
|
||||
(string-locale>? "chxxx" "hxxx")
|
||||
(string-locale<? "chxxxx" "ixxx"))
|
||||
(throw 'unresolved))))))
|
||||
|
||||
|
||||
(with-test-prefix "character mapping"
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;;; numbers.test --- tests guile's numbers -*- scheme -*-
|
||||
;;;; Copyright (C) 2000, 2001, 2003, 2004, 2005, 2006, 2009, 2010, 2011,
|
||||
;;;; 2012, 2013 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2000, 2001, 2003-2006, 2009-2013,
|
||||
;;;; 2015 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
|
||||
|
|
@ -4467,7 +4467,8 @@
|
|||
(pass-if (eqv? 0 (atan 0)))
|
||||
(pass-if (eqv? 0.0 (atan 0.0)))
|
||||
(pass-if (eqv-loosely? 1.57 (atan +inf.0)))
|
||||
(pass-if (eqv-loosely? -1.57 (atan -inf.0))))
|
||||
(pass-if (eqv-loosely? -1.57 (atan -inf.0)))
|
||||
(pass-if (eqv-loosely? -1.42+0.5i (atan -0.5+2.0i))))
|
||||
|
||||
;;;
|
||||
;;; sinh
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
;;;; posix.test --- Test suite for Guile POSIX functions. -*- scheme -*-
|
||||
;;;;
|
||||
;;;; Copyright 2003, 2004, 2006, 2007, 2010, 2012 Free Software Foundation, Inc.
|
||||
;;;; Copyright 2003, 2004, 2006, 2007, 2010, 2012,
|
||||
;;;; 2015 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
|
||||
|
|
@ -195,9 +196,18 @@
|
|||
|
||||
(pass-if "setaffinity"
|
||||
(if (and (defined? 'setaffinity) (defined? 'getaffinity))
|
||||
(let ((mask (getaffinity (getpid))))
|
||||
(setaffinity (getpid) mask)
|
||||
(equal? mask (getaffinity (getpid))))
|
||||
(catch 'system-error
|
||||
(lambda ()
|
||||
(let ((mask (getaffinity (getpid))))
|
||||
(setaffinity (getpid) mask)
|
||||
(equal? mask (getaffinity (getpid)))))
|
||||
(lambda args
|
||||
;; On some platforms such as sh4-linux-gnu, 'setaffinity'
|
||||
;; returns ENOSYS.
|
||||
(let ((errno (system-error-errno args)))
|
||||
(if (= errno ENOSYS)
|
||||
(throw 'unresolved)
|
||||
(apply throw args)))))
|
||||
(throw 'unresolved))))
|
||||
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -356,6 +356,11 @@
|
|||
(with-fluids ((%default-port-encoding "UTF-8"))
|
||||
(binary-port? (open-bytevector-input-port #vu8(1 2 3)))))
|
||||
|
||||
(pass-if-equal "bytevector-input-port uses ISO-8859-1 (Guile extension)"
|
||||
"©©"
|
||||
(with-fluids ((%default-port-encoding "UTF-8"))
|
||||
(get-string-all (open-bytevector-input-port #vu8(194 169 194 169)))))
|
||||
|
||||
(pass-if-exception "bytevector-input-port is read-only"
|
||||
exception:wrong-type-arg
|
||||
|
||||
|
|
@ -416,6 +421,23 @@
|
|||
(input-port? port)
|
||||
(bytevector=? (get-bytevector-all port) source))))
|
||||
|
||||
(pass-if-equal "make-custom-binary-input-port uses ISO-8859-1 (Guile extension)"
|
||||
"©©"
|
||||
(with-fluids ((%default-port-encoding "UTF-8"))
|
||||
(let* ((source #vu8(194 169 194 169))
|
||||
(read! (let ((pos 0)
|
||||
(len (bytevector-length source)))
|
||||
(lambda (bv start count)
|
||||
(let ((amount (min count (- len pos))))
|
||||
(if (> amount 0)
|
||||
(bytevector-copy! source pos
|
||||
bv start amount))
|
||||
(set! pos (+ pos amount))
|
||||
amount))))
|
||||
(port (make-custom-binary-input-port "the port" read!
|
||||
#f #f #f)))
|
||||
(get-string-all port))))
|
||||
|
||||
(pass-if "custom binary input port does not support `port-position'"
|
||||
(let* ((str "Hello Port!")
|
||||
(source (open-bytevector-input-port
|
||||
|
|
@ -716,6 +738,14 @@ not `set-port-position!'"
|
|||
(pass-if "bytevector-output-port is binary"
|
||||
(binary-port? (open-bytevector-output-port)))
|
||||
|
||||
(pass-if-equal "bytevector-output-port uses ISO-8859-1 (Guile extension)"
|
||||
#vu8(194 169 194 169)
|
||||
(with-fluids ((%default-port-encoding "UTF-8"))
|
||||
(let-values (((port get-content)
|
||||
(open-bytevector-output-port)))
|
||||
(put-string port "©©")
|
||||
(get-content))))
|
||||
|
||||
(pass-if "open-bytevector-output-port [extract after close]"
|
||||
(let-values (((port get-content)
|
||||
(open-bytevector-output-port)))
|
||||
|
|
@ -819,6 +849,23 @@ not `set-port-position!'"
|
|||
(not eof?)
|
||||
(bytevector=? sink source))))
|
||||
|
||||
(pass-if-equal "custom-binary-output-port uses ISO-8859-1 (Guile extension)"
|
||||
'(194 169 194 169)
|
||||
(with-fluids ((%default-port-encoding "UTF-8"))
|
||||
(let* ((sink '())
|
||||
(write! (lambda (bv start count)
|
||||
(if (= 0 count) ; EOF
|
||||
0
|
||||
(let ((u8 (bytevector-u8-ref bv start)))
|
||||
;; Get one byte at a time.
|
||||
(set! sink (cons u8 sink))
|
||||
1))))
|
||||
(port (make-custom-binary-output-port "cbop" write!
|
||||
#f #f #f)))
|
||||
(put-string port "©©")
|
||||
(force-output port)
|
||||
(reverse sink))))
|
||||
|
||||
(pass-if "standard-output-port is binary"
|
||||
(with-fluids ((%default-port-encoding "UTF-8"))
|
||||
(binary-port? (standard-output-port))))
|
||||
|
|
|
|||
|
|
@ -60,6 +60,11 @@
|
|||
(lambda ()
|
||||
(read-options saved-options)))))
|
||||
|
||||
(define (read-string-as-list s)
|
||||
(with-input-from-string s
|
||||
(lambda ()
|
||||
(unfold eof-object? values (lambda (x) (read)) (read)))))
|
||||
|
||||
|
||||
(with-test-prefix "reading"
|
||||
(pass-if "0"
|
||||
|
|
@ -432,14 +437,42 @@
|
|||
(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))))))))
|
||||
(read-string-as-list "GUIle #!no-fold-case GuiLe gUIle")))))
|
||||
(pass-if "case-insensitive"
|
||||
(equal? '(GUIle guile guile)
|
||||
(with-input-from-string "GUIle #!fold-case GuiLe gUIle"
|
||||
(lambda ()
|
||||
(list (read) (read) (read)))))))
|
||||
(read-string-as-list "GUIle #!fold-case GuiLe gUIle")))
|
||||
(with-test-prefix "r6rs"
|
||||
(pass-if-equal "case sensitive"
|
||||
'(guile GuiLe gUIle)
|
||||
(with-read-options '(case-insensitive)
|
||||
(lambda ()
|
||||
(read-string-as-list "GUIle #!r6rs GuiLe gUIle"))))
|
||||
(pass-if-equal "square brackets"
|
||||
'((a b c) (foo 42 bar) (x . y))
|
||||
(read-string-as-list "(a b c) #!r6rs [foo 42 bar] [x . y]"))
|
||||
(pass-if-equal "hex string escapes"
|
||||
'("native\x7fsyntax"
|
||||
"\0"
|
||||
"ascii\x7fcontrol"
|
||||
"U\u0100BMP"
|
||||
"U\U010402SMP")
|
||||
(read-string-as-list (string-append "\"native\\x7fsyntax\" "
|
||||
"#!r6rs "
|
||||
"\"\\x0;\" "
|
||||
"\"ascii\\x7f;control\" "
|
||||
"\"U\\x100;BMP\" "
|
||||
"\"U\\x10402;SMP\"")))
|
||||
(with-test-prefix "keyword style"
|
||||
(pass-if-equal "postfix disabled"
|
||||
'(#:regular #:postfix postfix: #:regular2)
|
||||
(with-read-options '(keywords postfix)
|
||||
(lambda ()
|
||||
(read-string-as-list "#:regular postfix: #!r6rs postfix: #:regular2"))))
|
||||
(pass-if-equal "prefix disabled"
|
||||
'(#:regular #:prefix :prefix #:regular2)
|
||||
(with-read-options '(keywords prefix)
|
||||
(lambda ()
|
||||
(read-string-as-list "#:regular :prefix #!r6rs :prefix #:regular2")))))))
|
||||
|
||||
(with-test-prefix "#;"
|
||||
(for-each
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
;;;; strings.test --- test suite for Guile's string functions -*- scheme -*-
|
||||
;;;; Jim Blandy <jimb@red-bean.com> --- August 1999
|
||||
;;;;
|
||||
;;;; Copyright (C) 1999, 2001, 2004, 2005, 2006, 2008, 2009, 2010,
|
||||
;;;; 2011, 2013 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 1999, 2001, 2004-2006, 2008-2011, 2013,
|
||||
;;;; 2015 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
|
||||
|
|
@ -457,6 +457,22 @@
|
|||
(pass-if "compatibility composition is equal?"
|
||||
(equal? (string-normalize-nfkc "\u1e9b\u0323") "\u1e69")))
|
||||
|
||||
;;
|
||||
;; string-utf8-length
|
||||
;;
|
||||
|
||||
(with-test-prefix "string-utf8-length"
|
||||
|
||||
(pass-if-exception "wrong type argument"
|
||||
exception:wrong-type-arg
|
||||
(string-utf8-length 50))
|
||||
|
||||
(pass-if-equal 0 (string-utf8-length ""))
|
||||
(pass-if-equal 1 (string-utf8-length "\0"))
|
||||
(pass-if-equal 5 (string-utf8-length "hello"))
|
||||
(pass-if-equal 7 (string-utf8-length "helloλ"))
|
||||
(pass-if-equal 9 (string-utf8-length "ሠላም")))
|
||||
|
||||
;;
|
||||
;; string-ref
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;;; web-uri.test --- URI library -*- mode: scheme; coding: utf-8; -*-
|
||||
;;;; web-http.test --- HTTP library -*- mode: scheme; coding: utf-8; -*-
|
||||
;;;;
|
||||
;;;; Copyright (C) 2010, 2011, 2014, 2016 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2010-2011, 2014-2016 Free Software Foundation, Inc.
|
||||
;;;;
|
||||
;;;; This library is free software; you can redistribute it and/or
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -20,6 +20,7 @@
|
|||
(define-module (test-suite web-http)
|
||||
#:use-module (web uri)
|
||||
#:use-module (web http)
|
||||
#:use-module (rnrs bytevectors)
|
||||
#:use-module (rnrs io ports)
|
||||
#:use-module (ice-9 regex)
|
||||
#:use-module (ice-9 control)
|
||||
|
|
@ -185,10 +186,19 @@
|
|||
(1 . 1)))
|
||||
|
||||
(with-test-prefix "read-response-line"
|
||||
(pass-if-exception "missing CR/LF"
|
||||
`(bad-header . "")
|
||||
(call-with-input-string "HTTP/1.1 200 Almost okay"
|
||||
(lambda (port)
|
||||
(read-response-line port))))
|
||||
(pass-if-read-response-line "HTTP/1.0 404 Not Found"
|
||||
(1 . 0) 404 "Not Found")
|
||||
(pass-if-read-response-line "HTTP/1.1 200 OK"
|
||||
(1 . 1) 200 "OK"))
|
||||
(1 . 1) 200 "OK")
|
||||
|
||||
;; Empty reason phrases are valid; see <http://bugs.gnu.org/22273>.
|
||||
(pass-if-read-response-line "HTTP/1.1 302 "
|
||||
(1 . 1) 302 ""))
|
||||
|
||||
(with-test-prefix "write-response-line"
|
||||
(pass-if-write-response-line "HTTP/1.0 404 Not Found"
|
||||
|
|
@ -226,6 +236,16 @@
|
|||
(pass-if-parse date "Wed, 7 Sep 2011 11:25:00 GMT"
|
||||
(string->date "Wed, 7 Sep 2011 11:25:00 +0000"
|
||||
"~a,~e ~b ~Y ~H:~M:~S ~z"))
|
||||
|
||||
;; This is a non-conforming date (lack of leading zero for the hours)
|
||||
;; that some HTTP servers provide. See <http://bugs.gnu.org/23421>.
|
||||
(pass-if-parse date "Sun, 06 Nov 1994 8:49:37 GMT"
|
||||
(string->date "Sun, 6 Nov 1994 08:49:37 +0000"
|
||||
"~a,~e ~b ~Y ~H:~M:~S ~z"))
|
||||
(pass-if-parse date "Sun, 6 Nov 1994 8:49:37 GMT"
|
||||
(string->date "Sun, 6 Nov 1994 08:49:37 +0000"
|
||||
"~a,~e ~b ~Y ~H:~M:~S ~z"))
|
||||
|
||||
(pass-if-parse-error date "Tue, 15 Nov 1994 08:12:31 EST" date)
|
||||
(pass-if-any-error date "Tue, 15 Qux 1994 08:12:31 EST")
|
||||
|
||||
|
|
@ -369,18 +389,78 @@
|
|||
(with-test-prefix "chunked encoding"
|
||||
(let* ((s "5\r\nFirst\r\nA\r\n line\n Sec\r\n8\r\nond line\r\n0\r\n")
|
||||
(p (make-chunked-input-port (open-input-string s))))
|
||||
(pass-if (equal? "First line\n Second line"
|
||||
(get-string-all p)))
|
||||
(pass-if (port-eof? (make-chunked-input-port (open-input-string "0\r\n")))))
|
||||
(pass-if
|
||||
(equal? (call-with-output-string
|
||||
(lambda (out-raw)
|
||||
(let ((out-chunked (make-chunked-output-port out-raw
|
||||
#:keep-alive? #t)))
|
||||
(display "First chunk" out-chunked)
|
||||
(force-output out-chunked)
|
||||
(display "Second chunk" out-chunked)
|
||||
(force-output out-chunked)
|
||||
(display "Third chunk" out-chunked)
|
||||
(close-port out-chunked))))
|
||||
"b\r\nFirst chunk\r\nc\r\nSecond chunk\r\nb\r\nThird chunk\r\n0\r\n")))
|
||||
(pass-if-equal
|
||||
"First line\n Second line"
|
||||
(get-string-all p))
|
||||
(pass-if (port-eof? (make-chunked-input-port (open-input-string "0\r\n"))))
|
||||
|
||||
(pass-if-equal "reads chunks without buffering"
|
||||
;; Make sure the chunked input port does not read more than what
|
||||
;; the client asked. See <http://bugs.gnu.org/19939>
|
||||
`("First " "chunk." "Second " "chunk."
|
||||
(1 1 1 6 6 1 1
|
||||
1 1 1 7 6 1 1))
|
||||
(let* ((str "C\r\nFirst chunk.\r\nD\r\nSecond chunk.\r\n")
|
||||
(requests '())
|
||||
(read! (let ((port (open-input-string str)))
|
||||
(lambda (bv index count)
|
||||
(set! requests (cons count requests))
|
||||
(let ((n (get-bytevector-n! port bv index
|
||||
count)))
|
||||
(if (eof-object? n) 0 n)))))
|
||||
(input (make-custom-binary-input-port "chunky" read!
|
||||
#f #f #f))
|
||||
(port (make-chunked-input-port input)))
|
||||
(setvbuf input _IONBF)
|
||||
(setvbuf port _IONBF)
|
||||
(list (utf8->string (get-bytevector-n port 6))
|
||||
(utf8->string (get-bytevector-n port 6))
|
||||
(utf8->string (get-bytevector-n port 7))
|
||||
(utf8->string (get-bytevector-n port 6))
|
||||
(reverse requests))))
|
||||
|
||||
(pass-if-equal "reads across chunk boundaries"
|
||||
;; Same, but read across chunk boundaries.
|
||||
`("First " "chunk.Second " "chunk."
|
||||
(1 1 1 6 6 1 1
|
||||
1 1 1 7 6 1 1))
|
||||
(let* ((str "C\r\nFirst chunk.\r\nD\r\nSecond chunk.\r\n")
|
||||
(requests '())
|
||||
(read! (let ((port (open-input-string str)))
|
||||
(lambda (bv index count)
|
||||
(set! requests (cons count requests))
|
||||
(let ((n (get-bytevector-n! port bv index
|
||||
count)))
|
||||
(if (eof-object? n) 0 n)))))
|
||||
(input (make-custom-binary-input-port "chunky" read!
|
||||
#f #f #f))
|
||||
(port (make-chunked-input-port input)))
|
||||
(setvbuf input _IONBF)
|
||||
(setvbuf port _IONBF)
|
||||
(list (utf8->string (get-bytevector-n port 6))
|
||||
(utf8->string (get-bytevector-n port 13))
|
||||
(utf8->string (get-bytevector-n port 6))
|
||||
(reverse requests)))))
|
||||
|
||||
(pass-if-equal "EOF instead of chunk header"
|
||||
"Only chunk."
|
||||
;; Omit the second chunk header, leading to a premature EOF. This
|
||||
;; used to cause 'read-chunk-header' to throw to wrong-type-arg.
|
||||
;; See the backtrace at
|
||||
;; <http://debbugs.gnu.org/cgi/bugreport.cgi?bug=19976#5>.
|
||||
(let* ((str "B\r\nOnly chunk.")
|
||||
(port (make-chunked-input-port (open-input-string str))))
|
||||
(get-string-all port)))
|
||||
|
||||
(pass-if-equal
|
||||
(call-with-output-string
|
||||
(lambda (out-raw)
|
||||
(let ((out-chunked (make-chunked-output-port out-raw
|
||||
#:keep-alive? #t)))
|
||||
(display "First chunk" out-chunked)
|
||||
(force-output out-chunked)
|
||||
(display "Second chunk" out-chunked)
|
||||
(force-output out-chunked)
|
||||
(display "Third chunk" out-chunked)
|
||||
(close-port out-chunked))))
|
||||
"b\r\nFirst chunk\r\nc\r\nSecond chunk\r\nb\r\nThird chunk\r\n0\r\n"))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;;; web-response.test --- HTTP responses -*- mode: scheme; coding: utf-8; -*-
|
||||
;;;;
|
||||
;;;; Copyright (C) 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2010-2016 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
|
||||
|
|
@ -119,7 +119,17 @@ consectetur adipisicing elit,\r
|
|||
(with-fluids ((%default-port-encoding #f))
|
||||
(let* ((r (read-response (open-input-string example-1)))
|
||||
(p (response-body-port r)))
|
||||
(list (port-encoding p) (get-bytevector-all p)))))))
|
||||
(list (port-encoding p) (get-bytevector-all p)))))
|
||||
|
||||
(pass-if "response-body-port + close"
|
||||
(with-fluids ((%default-port-encoding #f))
|
||||
(let* ((r (read-response (open-input-string example-1)))
|
||||
(p (response-body-port r #:keep-alive? #f)))
|
||||
;; Before, calling 'close-port' here would yield a
|
||||
;; wrong-arg-num error when calling the delimited input port's
|
||||
;; 'close' procedure.
|
||||
(close-port p)
|
||||
(port-closed? p))))))
|
||||
|
||||
(with-test-prefix "example-2"
|
||||
(let* ((r (read-response (open-input-string example-2)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue