[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-509-gfcd953f
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-509-gfcd953f |
|
Date: |
Thu, 28 Nov 2013 15:18:57 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=fcd953f6990a813a204beea6992bc4287bb94513
The branch, master has been updated
via fcd953f6990a813a204beea6992bc4287bb94513 (commit)
via 5dfafc3c76b70acfdb7d47611478d1f9a737ac18 (commit)
via ae9c16e89565f997936778a710d5addf1ec256c2 (commit)
via 9b95f3ced4f4cc4c7d0ffa59c530a2e1a17a19fc (commit)
via 6683f204ba95321f2cf904d0508117b027f2f2fc (commit)
via f76cf73a49e0219f81a2fa0fc8431a0b83280822 (commit)
via 6dd98109020997d22f78d9cd516d7809c4fcc493 (commit)
via acf7530a3ed55f15f6275f0419ef4347f8eb6f6c (commit)
via 091dd0cc58ea54c71bdef2e5804cf21095b342d5 (commit)
via d364a8971828e38e8f9112b711066f4962bb400e (commit)
via e7bd20f7d9b2110fdc0fa25db5a2bfe6b2214923 (commit)
via 17330398d50524058c2ef488bd21ac5ec9c8b6e8 (commit)
via a38024baaa32d1a6d91fdc81388c88bbb926c3ae (commit)
via 2437c7b2e8b4ab7786847ee1ce0b59e446a70fe2 (commit)
via 8571dbde639e0ee9885bad49c9e180474bd23646 (commit)
via e676a4c34211efc8a7558afb0f8572b88a89c683 (commit)
via 1e42832af07ea6ac68ecbe4f6a3376ff509a2a51 (commit)
via 8904b7a9362ede0de324e55701d8ea1d018f8738 (commit)
via a4ecb437bc5b8bcdaad085dc413110db29591795 (commit)
via 5063f0a93bb4349ee527b6fd98ff50ea9fa0fe42 (commit)
via 02500d44775a77e46febfd47a0dab8233b0c99d0 (commit)
via 750ac8c592e792e627444f476877f282525b132e (commit)
via 363df6cf108763e24eb5cb149131a3fa3f400734 (commit)
via 4a0fb276a911d5a2760818af2901c75673df5a93 (commit)
via 36c40440078c005cd5e239cca487d29f6f60007d (commit)
via b1fe20c24ccb380420ea1ffdc7f249224072dcdc (commit)
via 9cdf0ac603303ed8940a29d4fc4d8454f97b79aa (commit)
via c9e3266c4b9420a8138d277dd5f3cfe3e208e152 (commit)
via c61be45084d04b1db792b7e232f5bd77099f3287 (commit)
via aaa9ef33d8ace7c3060fa05c9a8bc64434616476 (commit)
via d360671c1cca335600079f1c5714572d1c2e676d (commit)
via 1ea0803e9ea1d5afede0eff8175d0cba12bab49e (commit)
from 553294d958c953f57658bad45affc15b55fcc471 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit fcd953f6990a813a204beea6992bc4287bb94513
Merge: 5dfafc3 d364a89
Author: Andy Wingo <address@hidden>
Date: Thu Nov 28 16:16:48 2013 +0100
Merge commit 'd364a8971828e38e8f9112b711066f4962bb400e'
Conflicts:
libguile/deprecated.h
libguile/gc.c
commit 5dfafc3c76b70acfdb7d47611478d1f9a737ac18
Merge: ae9c16e e7bd20f
Author: Andy Wingo <address@hidden>
Date: Thu Nov 28 16:15:55 2013 +0100
Merge commit 'e7bd20f7d9b2110fdc0fa25db5a2bfe6b2214923'
commit ae9c16e89565f997936778a710d5addf1ec256c2
Merge: 9b95f3c 1733039
Author: Andy Wingo <address@hidden>
Date: Thu Nov 28 16:15:51 2013 +0100
Merge commit '17330398d50524058c2ef488bd21ac5ec9c8b6e8'
commit 9b95f3ced4f4cc4c7d0ffa59c530a2e1a17a19fc
Merge: 6683f20 a38024b
Author: Andy Wingo <address@hidden>
Date: Thu Nov 28 16:15:38 2013 +0100
Merge commit 'a38024baaa32d1a6d91fdc81388c88bbb926c3ae'
Conflicts:
libguile/ports.h
commit 6683f204ba95321f2cf904d0508117b027f2f2fc
Merge: f76cf73 2437c7b
Author: Andy Wingo <address@hidden>
Date: Thu Nov 28 16:03:58 2013 +0100
Merge commit '2437c7b2e8b4ab7786847ee1ce0b59e446a70fe2'
Conflicts:
libguile/guardians.c
commit f76cf73a49e0219f81a2fa0fc8431a0b83280822
Merge: 6dd9810 8571dbd
Author: Andy Wingo <address@hidden>
Date: Thu Nov 28 15:00:17 2013 +0100
Merge commit '8571dbde639e0ee9885bad49c9e180474bd23646'
Conflicts:
libguile/procprop.c
commit 6dd98109020997d22f78d9cd516d7809c4fcc493
Merge: acf7530 750ac8c
Author: Andy Wingo <address@hidden>
Date: Thu Nov 28 14:53:03 2013 +0100
Merge commit '750ac8c592e792e627444f476877f282525b132e'
Conflicts:
.gitignore
libguile/deprecated.c
commit acf7530a3ed55f15f6275f0419ef4347f8eb6f6c
Merge: 091dd0c c61be45
Author: Andy Wingo <address@hidden>
Date: Thu Nov 28 14:47:38 2013 +0100
Merge commit 'c61be45084d04b1db792b7e232f5bd77099f3287'
Conflicts:
libguile/ports.c
commit 091dd0cc58ea54c71bdef2e5804cf21095b342d5
Merge: 553294d d360671
Author: Andy Wingo <address@hidden>
Date: Thu Nov 28 14:46:24 2013 +0100
Merge commit 'd360671c1cca335600079f1c5714572d1c2e676d'
-----------------------------------------------------------------------
Summary of changes:
.gitignore | 4 +
THANKS | 1 +
doc/ref/api-compound.texi | 43 ++++++---
doc/ref/libguile-smobs.texi | 174 +++++++++++----------------------
doc/ref/srfi-modules.texi | 4 +-
libguile/__scm.h | 2 +-
libguile/async.h | 16 +++
libguile/gc.c | 39 --------
libguile/gc.h | 1 -
libguile/guardians.c | 18 +++-
libguile/i18n.c | 4 +-
libguile/numbers.c | 2 +-
libguile/ports.c | 25 ++++-
libguile/ports.h | 6 +-
libguile/read.c | 23 ++---
libguile/threads.c | 16 +++
libguile/threads.h | 1 +
libguile/throw.c | 2 +-
libguile/throw.h | 2 +-
module/Makefile.am | 1 +
module/ice-9/hash-table.scm | 45 +++++++++
module/ice-9/popen.scm | 105 +++++++++++---------
module/ice-9/psyntax-pp.scm | 9 ++-
module/ice-9/psyntax.scm | 12 ++-
module/rnrs/exceptions.scm | 160 +++++++++++++++++++++++++++---
module/web/http.scm | 2 +
test-suite/tests/exceptions.test | 26 +++---
test-suite/tests/hash.test | 38 +++++++-
test-suite/tests/r6rs-exceptions.test | 62 +++++++++++-
29 files changed, 565 insertions(+), 278 deletions(-)
create mode 100644 module/ice-9/hash-table.scm
diff --git a/.gitignore b/.gitignore
index b136c7a..12cbc32 100644
--- a/.gitignore
+++ b/.gitignore
@@ -150,10 +150,14 @@ INSTALL
/lib/dirent.h
/lib/langinfo.h
/lib/wctype.h
+/lib/poll.h
+/lib/sys/select.h
+/lib/sys/times.h
/build-aux/ar-lib
/build-aux/test-driver
*.trs
/test-suite/standalone/test-smob-mark
/test-suite/standalone/test-scm-values
/test-suite/standalone/test-scm-to-latin1-string
+/test-suite/standalone/test-scm-c-bind-keyword-arguments
/libguile/vm-operations.h
diff --git a/THANKS b/THANKS
index ea7c8c3..63f8feb 100644
--- a/THANKS
+++ b/THANKS
@@ -29,6 +29,7 @@ Contributors since the last release:
Kevin Ryde
Stefan I Tampe
BT Templeton
+ David Thompson
Bake Timmons
Mark H Weaver
Göran Weinholt
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index 1990d77..0b14c48 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -689,22 +689,18 @@ Vectors can literally be entered in source code, just
like strings,
characters or some of the other data types. The read syntax for vectors
is as follows: A sharp sign (@code{#}), followed by an opening
parentheses, all elements of the vector in their respective read syntax,
-and finally a closing parentheses. The following are examples of the
-read syntax for vectors; where the first vector only contains numbers
-and the second three different object types: a string, a symbol and a
-number in hexadecimal notation.
+and finally a closing parentheses. Like strings, vectors do not have to
+be quoted.
+
+The following are examples of the read syntax for vectors; where the
+first vector only contains numbers and the second three different object
+types: a string, a symbol and a number in hexadecimal notation.
@lisp
#(1 2 3)
#("Hello" foo #xdeadbeef)
@end lisp
-Like lists, vectors have to be quoted:
-
address@hidden
-'#(a b c) @result{} #(a b c)
address@hidden lisp
-
@node Vector Creation
@subsubsection Dynamic Vector Creation and Validation
@@ -735,7 +731,7 @@ The inverse operation is @code{vector->list}:
Return a newly allocated list composed of the elements of @var{v}.
@lisp
-(vector->list '#(dah dah didah)) @result{} (dah dah didah)
+(vector->list #(dah dah didah)) @result{} (dah dah didah)
(list->vector '(dididit dah)) @result{} #(dididit dah)
@end lisp
@end deffn
@@ -796,8 +792,8 @@ Return the number of elements in @var{vec} as a
@code{size_t}.
Return the contents of position @var{k} of @var{vec}.
@var{k} must be a valid index of @var{vec}.
@lisp
-(vector-ref '#(1 1 2 3 5 8 13 21) 5) @result{} 8
-(vector-ref '#(1 1 2 3 5 8 13 21)
+(vector-ref #(1 1 2 3 5 8 13 21) 5) @result{} 8
+(vector-ref #(1 1 2 3 5 8 13 21)
(let ((i (round (* 2 (acos -1)))))
(if (inexact? i)
(inexact->exact i)
@@ -3833,6 +3829,27 @@ then it can use @var{size} to avoid rehashing when
initial entries are
added.
@end deffn
address@hidden {Scheme Procedure} alist->hash-table alist
address@hidden {Scheme Procedure} alist->hashq-table alist
address@hidden {Scheme Procedure} alist->hashv-table alist
address@hidden {Scheme Procedure} alist->hashx-table hash assoc alist
+Convert @var{alist} into a hash table. When keys are repeated in
address@hidden, the leftmost association takes precedence.
+
address@hidden
+(use-modules (ice-9 hash-table))
+(alist->hash-table '((foo . 1) (bar . 2)))
address@hidden example
+
+When converting to an extended hash table, custom @var{hash} and
address@hidden procedures must be provided.
+
address@hidden
+(alist->hashx-table hash assoc '((foo . 1) (bar . 2)))
address@hidden example
+
address@hidden deffn
+
@deffn {Scheme Procedure} hash-table? obj
@deffnx {C Function} scm_hash_table_p (obj)
Return @code{#t} if @var{obj} is a abstract hash table object.
diff --git a/doc/ref/libguile-smobs.texi b/doc/ref/libguile-smobs.texi
index 6f7c0f4..572bcf3 100644
--- a/doc/ref/libguile-smobs.texi
+++ b/doc/ref/libguile-smobs.texi
@@ -31,7 +31,6 @@ datatypes described here.)
* Creating Smob Instances::
* Type checking::
* Garbage Collecting Smobs::
-* Garbage Collecting Simple Smobs::
* Remembering During Operations::
* Double Smobs::
* The Complete Example::
@@ -40,31 +39,10 @@ datatypes described here.)
@node Describing a New Type
@subsection Describing a New Type
-To define a new type, the programmer must write four functions to
+To define a new type, the programmer must write two functions to
manage instances of the type:
@table @code
address@hidden mark
-Guile will apply this function to each instance of the new type it
-encounters during garbage collection. This function is responsible for
-telling the collector about any other @code{SCM} values that the object
-has stored. The default smob mark function does nothing.
address@hidden Collecting Smobs}, for more details.
-
address@hidden free
-Guile will apply this function to each instance of the new type that is
-to be deallocated. The function should release all resources held by
-the object. This is analogous to the Java finalization method-- it is
-invoked at an unspecified time (when garbage collection occurs) after
-the object is dead. The default free function frees the smob data (if
-the size of the struct passed to @code{scm_make_smob_type} is non-zero)
-using @code{scm_gc_free}. @xref{Garbage Collecting Smobs}, for more
-details.
-
-This function operates while the heap is in an inconsistent state and
-must therefore be careful. @xref{Smobs}, for details about what this
-function is allowed to do.
-
@item print
Guile will apply this function to each instance of the new type to print
the value, as for @code{display} or @code{write}. The default print
@@ -81,6 +59,32 @@ never @code{equal?} unless they are @code{eq?}.
@end table
+When the only resource associated with a smob is memory managed by the
+garbage collector---i.e., memory allocated with the @code{scm_gc_malloc}
+functions---this is sufficient. However, when a smob is associated with
+other kinds of resources, it may be necessary to define one of the
+following functions, or both:
+
address@hidden @code
address@hidden mark
+Guile will apply this function to each instance of the new type it
+encounters during garbage collection. This function is responsible for
+telling the collector about any other @code{SCM} values that the object
+has stored, and that are in memory regions not already scanned by the
+garbage collector. @xref{Garbage Collecting Smobs}, for more details.
+
address@hidden free
+Guile will apply this function to each instance of the new type that is
+to be deallocated. The function should release all resources held by
+the object. This is analogous to the Java finalization method---it is
+invoked at an unspecified time (when garbage collection occurs) after
+the object is dead. @xref{Garbage Collecting Smobs}, for more details.
+
+This function operates while the heap is in an inconsistent state and
+must therefore be careful. @xref{Smobs}, for details about what this
+function is allowed to do.
address@hidden table
+
To actually register the new smob type, call @code{scm_make_smob_type}.
It returns a value of type @code{scm_t_bits} which identifies the new
smob type.
@@ -164,35 +168,11 @@ word of a smob, you should use the macros
@code{SCM_SMOB_OBJECT} and
@code{SCM_SET_SMOB_OBJECT} to access it.
Creating a smob instance can be tricky when it consists of multiple
-steps that allocate resources and might fail. It is recommended that
-you go about creating a smob in the following way:
-
address@hidden
address@hidden
-Allocate the memory block for holding the data with
address@hidden
address@hidden
-Initialize it to a valid state without calling any functions that might
-cause a non-local exits. For example, initialize pointers to NULL.
-Also, do not store @code{SCM} values in it that must be protected.
-Initialize these fields with @code{SCM_BOOL_F}.
-
-A valid state is one that can be safely acted upon by the @emph{mark}
-and @emph{free} functions of your smob type.
address@hidden
-Create the smob using @code{scm_new_smob}, passing it the initialized
-memory block. (This step will always succeed.)
address@hidden
-Complete the initialization of the memory block by, for example,
-allocating additional resources and making it point to them.
address@hidden itemize
-
-This procedure ensures that the smob is in a valid state as soon as it
-exists, that all resources that are allocated for the smob are
-properly associated with it so that they can be properly freed, and
-that no @code{SCM} values that need to be protected are stored in it
-while the smob does not yet completely exist and thus can not protect
-them.
+steps that allocate resources. Most of the time, this is mainly about
+allocating memory to hold associated data structures. Using memory
+managed by the garbage collector simplifies things: the garbage
+collector will automatically scan those data structures for pointers,
+and reclaim them when they are no longer referenced.
Continuing the example from above, if the global variable
@code{image_tag} contains a tag returned by @code{scm_make_smob_type},
@@ -229,44 +209,19 @@ make_image (SCM name, SCM s_width, SCM s_height)
*/
image->name = name;
image->pixels =
- scm_gc_malloc (width * height, "image pixels");
+ scm_gc_malloc_pointerless (width * height, "image pixels");
return smob;
@}
@end example
-Let us look at what might happen when @code{make_image} is called.
-
-The conversions of @var{s_width} and @var{s_height} to @code{int}s might
-fail and signal an error, thus causing a non-local exit. This is not a
-problem since no resources have been allocated yet that would have to be
-freed.
-
-The allocation of @var{image} in step 1 might fail, but this is likewise
-no problem.
-
-Step 2 can not exit non-locally. At the end of it, the @var{image}
-struct is in a valid state for the @code{mark_image} and
address@hidden functions (see below).
-
-Step 3 can not exit non-locally either. This is guaranteed by Guile.
-After it, @var{smob} contains a valid smob that is properly initialized
-and protected, and in turn can properly protect the Scheme values in its
address@hidden struct.
+We use @code{scm_gc_malloc_pointerless} for the pixel buffer to tell the
+garbage collector not to scan it for pointers. Calls to
address@hidden, @code{scm_new_smob}, and
address@hidden raise an exception in out-of-memory
+conditions; the garbage collector is able to reclaim previously
+allocated memory if that happens.
-But before the smob is completely created, @code{scm_new_smob} might
-cause the garbage collector to run. During this garbage collection, the
address@hidden values in the @var{image} struct would be invisible to Guile.
-It only gets to know about them via the @code{mark_image} function, but
-that function can not yet do its job since the smob has not been created
-yet. Thus, it is important to not store @code{SCM} values in the
address@hidden struct until after the smob has been created.
-
-Step 4, finally, might fail and cause a non-local exit. In that case,
-the complete creation of the smob has not been successful, but it does
-nevertheless exist in a valid state. It will eventually be freed by
-the garbage collector, and all the resources that have been allocated
-for it will be correctly freed by @code{free_image}.
@node Type checking
@subsection Type checking
@@ -310,8 +265,17 @@ to @code{scm_remember_upto_here_1}.
@subsection Garbage Collecting Smobs
Once a smob has been released to the tender mercies of the Scheme
-system, it must be prepared to survive garbage collection. Guile calls
-the @emph{mark} and @emph{free} functions of the smob to manage this.
+system, it must be prepared to survive garbage collection. In the
+example above, all the memory associated with the smob is managed by the
+garbage collector because we used the @code{scm_gc_} allocation
+functions. Thus, no special care must be taken: the garbage collector
+automatically scans them and reclaims any unused memory.
+
+However, when data associated with a smob is managed in some other
+way---e.g., @code{malloc}'d memory or file descriptors---it is possible
+to specify a @emph{free} function to release those resources when the
+smob is reclaimed, and a @emph{mark} function to mark Scheme objects
+otherwise invisible to the garbage collector.
As described in more detail elsewhere (@pxref{Conservative GC}), every
object in the Scheme system has a @dfn{mark bit}, which the garbage
@@ -343,7 +307,9 @@ values will have become dangling references.
To mark an arbitrary Scheme object, the @emph{mark} function calls
@code{scm_gc_mark}.
-Thus, here is how we might write @code{mark_image}:
+Thus, here is how we might write @code{mark_image}---again this is not
+needed in our example since we used the @code{scm_gc_} allocation
+routines, so this is just for the sake of illustration:
@example
@group
@@ -398,7 +364,8 @@ type of the @emph{free} function should be @code{size_t},
an unsigned
integral type; the @emph{free} function should always return zero.
Here is how we might write the @code{free_image} function for the image
-smob type:
+smob type---again for the sake of illustration, since our example does
+not need it thanks to the use of the @code{scm_gc_} allocation routines:
@example
size_t
free_image (SCM image_smob)
@@ -426,37 +393,12 @@ during garbage collection; keep the @emph{mark} and
@emph{free}
functions very simple. Since collections occur at unpredictable times,
it is easy for any unusual activity to interfere with normal code.
-
address@hidden Garbage Collecting Simple Smobs
address@hidden Garbage Collecting Simple Smobs
-
-It is often useful to define very simple smob types --- smobs which have
-no data to mark, other than the cell itself, or smobs whose immediate
-data word is simply an ordinary Scheme object, to be marked recursively.
-Guile provides some functions to handle these common cases; you can use
-this function as your smob type's @emph{mark} function, if your smob's
-structure is simple enough.
-
-If the smob refers to no other Scheme objects, then no action is
-necessary; the garbage collector has already marked the smob cell
-itself. In that case, you can use zero as your mark function.
-
-If the smob refers to exactly one other Scheme object via its first
-immediate word, you can use @code{scm_markcdr} as its mark function.
-Its definition is simply:
-
address@hidden
-SCM
-scm_markcdr (SCM obj)
address@hidden
- return SCM_SMOB_OBJECT (obj);
address@hidden
address@hidden smallexample
-
@node Remembering During Operations
@subsection Remembering During Operations
@cindex remembering
address@hidden FIXME: Remove this section?
+
It's important that a smob is visible to the garbage collector
whenever its contents are being accessed. Otherwise it could be freed
while code is still using it.
@@ -516,6 +458,8 @@ while the collector runs.)
@node Double Smobs
@subsection Double Smobs
address@hidden FIXME: Remove this section?
+
Smobs are called smob because they are small: they normally have only
room for one @code{void*} or @code{SCM} value plus 16 bits. The
reason for this is that smobs are directly implemented by using the
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index d97f498..32ff271 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -677,8 +677,8 @@ Maps each seed value to next seed value.
@item seed
The state value for the unfold.
address@hidden tail-gen
-Creates the tail of the list; defaults to @code{(lambda (x) '())}.
address@hidden tail
+The tail of the list; defaults to @code{'()}.
@end table
@end deffn
diff --git a/libguile/__scm.h b/libguile/__scm.h
index 0a749be..31e3952 100644
--- a/libguile/__scm.h
+++ b/libguile/__scm.h
@@ -77,7 +77,7 @@
* 1) int foo (char arg) SCM_NORETURN;
*/
#ifdef __GNUC__
-#define SCM_NORETURN __attribute__ ((noreturn))
+#define SCM_NORETURN __attribute__ ((__noreturn__))
#else
#define SCM_NORETURN
#endif
diff --git a/libguile/async.h b/libguile/async.h
index 68952b0..e6fe523 100644
--- a/libguile/async.h
+++ b/libguile/async.h
@@ -78,6 +78,22 @@ SCM_API void scm_critical_section_end (void);
scm_async_tick (); \
} while (0)
+# define scm_i_pthread_mutex_lock_block_asyncs(m) \
+ do \
+ { \
+ SCM_I_CURRENT_THREAD->block_asyncs++; \
+ scm_i_pthread_mutex_lock (m); \
+ } \
+ while (0)
+
+# define scm_i_pthread_mutex_unlock_unblock_asyncs(m) \
+ do \
+ { \
+ scm_i_pthread_mutex_unlock (m); \
+ SCM_I_CURRENT_THREAD->block_asyncs--; \
+ } \
+ while (0)
+
#else /* !BUILDING_LIBGUILE */
# define SCM_CRITICAL_SECTION_START scm_critical_section_start ()
diff --git a/libguile/gc.c b/libguile/gc.c
index d13d89b..4ec57aa 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -237,45 +237,6 @@ SCM_SYMBOL (sym_times, "gc-times");
/* {Scheme Interface to GC}
*/
-static char const * scm_i_tag_name (scm_t_bits tag);
-static SCM
-tag_table_to_type_alist (void *closure, SCM key, SCM val, SCM acc)
-{
- if (scm_is_integer (key))
- {
- int c_tag = scm_to_int (key);
-
- char const * name = scm_i_tag_name (c_tag);
- if (name != NULL)
- {
- key = scm_from_locale_string (name);
- }
- else
- {
- char s[100];
- sprintf (s, "tag %d", c_tag);
- key = scm_from_locale_string (s);
- }
- }
-
- return scm_cons (scm_cons (key, val), acc);
-}
-
-SCM_DEFINE (scm_gc_live_object_stats, "gc-live-object-stats", 0, 0, 0,
- (),
- "Return an alist of statistics of the current live objects. ")
-#define FUNC_NAME s_scm_gc_live_object_stats
-{
- SCM tab = scm_make_hash_table (scm_from_int (57));
- SCM alist;
-
- alist
- = scm_internal_hash_fold (&tag_table_to_type_alist, NULL, SCM_EOL, tab);
-
- return alist;
-}
-#undef FUNC_NAME
-
extern int scm_gc_malloc_yield_percentage;
SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
(),
diff --git a/libguile/gc.h b/libguile/gc.h
index 0857781..61fc9a2 100644
--- a/libguile/gc.h
+++ b/libguile/gc.h
@@ -150,7 +150,6 @@ SCM_API SCM scm_gc_enable (void);
SCM_API SCM scm_gc_disable (void);
SCM_API SCM scm_gc_dump (void);
SCM_API SCM scm_gc_stats (void);
-SCM_API SCM scm_gc_live_object_stats (void);
SCM_API SCM scm_gc (void);
SCM_INTERNAL void scm_i_gc (const char *what);
SCM_API void scm_gc_mark (SCM p);
diff --git a/libguile/guardians.c b/libguile/guardians.c
index 7619acf..f2651a8 100644
--- a/libguile/guardians.c
+++ b/libguile/guardians.c
@@ -40,7 +40,6 @@
* monsters we had...
*
* Rewritten for the Boehm-Demers-Weiser GC by Ludovic Courtès.
- * FIXME: This is currently not thread-safe.
*/
/* Uncomment the following line to debug guardian finalization. */
@@ -71,6 +70,7 @@ static scm_t_bits tc16_guardian;
typedef struct t_guardian
{
+ scm_i_pthread_mutex_t mutex;
unsigned long live;
SCM zombies;
struct t_guardian *next;
@@ -146,6 +146,9 @@ finalize_guarded (void *ptr, void *finalizer_data)
}
g = GUARDIAN_DATA (guardian);
+
+ scm_i_pthread_mutex_lock_block_asyncs (&g->mutex);
+
if (g->live == 0)
abort ();
@@ -159,7 +162,8 @@ finalize_guarded (void *ptr, void *finalizer_data)
g->zombies = zombies;
g->live--;
- g->zombies = zombies;
+
+ scm_i_pthread_mutex_unlock_unblock_asyncs (&g->mutex);
}
if (scm_is_true (proxied_finalizer))
@@ -210,6 +214,8 @@ scm_i_guard (SCM guardian, SCM obj)
void *prev_data;
SCM guardians_for_obj, finalizer_data;
+ scm_i_pthread_mutex_lock_block_asyncs (&g->mutex);
+
g->live++;
/* Note: GUARDIANS_FOR_OBJ holds weak references to guardians so
@@ -253,6 +259,8 @@ scm_i_guard (SCM guardian, SCM obj)
SCM_PACK_POINTER (prev_data));
SCM_SETCAR (finalizer_data, proxied_finalizer);
}
+
+ scm_i_pthread_mutex_unlock_unblock_asyncs (&g->mutex);
}
}
@@ -262,6 +270,8 @@ scm_i_get_one_zombie (SCM guardian)
t_guardian *g = GUARDIAN_DATA (guardian);
SCM res = SCM_BOOL_F;
+ scm_i_pthread_mutex_lock_block_asyncs (&g->mutex);
+
if (!scm_is_null (g->zombies))
{
/* Note: We return zombies in reverse order. */
@@ -269,6 +279,8 @@ scm_i_get_one_zombie (SCM guardian)
g->zombies = SCM_CDR (g->zombies);
}
+ scm_i_pthread_mutex_unlock_unblock_asyncs (&g->mutex);
+
return res;
}
@@ -339,6 +351,8 @@ SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 0, 0,
t_guardian *g = scm_gc_malloc (sizeof (t_guardian), "guardian");
SCM z;
+ scm_i_pthread_mutex_init (&g->mutex, NULL);
+
/* A tconc starts out with one tail pair. */
g->live = 0;
g->zombies = SCM_EOL;
diff --git a/libguile/i18n.c b/libguile/i18n.c
index dc6d07d..0f607f3 100644
--- a/libguile/i18n.c
+++ b/libguile/i18n.c
@@ -1535,7 +1535,9 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
codeset = nl_langinfo (CODESET);
}
- c_result = strdup (c_result);
+ if (c_result != NULL)
+ c_result = strdup (c_result);
+
unlock_locale_mutex ();
if (c_result == NULL)
diff --git a/libguile/numbers.c b/libguile/numbers.c
index b91f4c3..2ed98d3 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -4998,7 +4998,7 @@ left_shift_exact_integer (SCM n, long count)
mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result),
count);
return scm_i_normbig (result);
- }
+ }
}
else if (SCM_BIGP (n))
{
diff --git a/libguile/ports.c b/libguile/ports.c
index 960dfa8..61bd577 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -60,6 +60,7 @@
#include "libguile/weak-set.h"
#include "libguile/fluids.h"
#include "libguile/eq.h"
+#include "libguile/alist.h"
#ifdef HAVE_STRING_H
#include <string.h>
@@ -342,17 +343,29 @@ scm_i_clear_pending_eof (SCM port)
SCM_PORT_GET_INTERNAL (port)->pending_eof = 0;
}
-SCM
-scm_i_port_alist (SCM port)
+SCM_DEFINE (scm_i_port_property, "%port-property", 2, 0, 0,
+ (SCM port, SCM key),
+ "Return the property of @var{port} associated with @var{key}.")
+#define FUNC_NAME s_scm_i_port_property
{
- return SCM_PORT_GET_INTERNAL (port)->alist;
+ SCM_VALIDATE_OPPORT (1, port);
+ return scm_assq_ref (SCM_PORT_GET_INTERNAL (port)->alist, key);
}
+#undef FUNC_NAME
-void
-scm_i_set_port_alist_x (SCM port, SCM alist)
+SCM_DEFINE (scm_i_set_port_property_x, "%set-port-property!", 3, 0, 0,
+ (SCM port, SCM key, SCM value),
+ "Set the property of @var{port} associated with @var{key} to
@var{value}.")
+#define FUNC_NAME s_scm_i_set_port_property_x
{
- SCM_PORT_GET_INTERNAL (port)->alist = alist;
+ scm_t_port_internal *pti;
+
+ SCM_VALIDATE_OPPORT (1, port);
+ pti = SCM_PORT_GET_INTERNAL (port);
+ pti->alist = scm_assq_set_x (pti->alist, key, value);
+ return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
diff --git a/libguile/ports.h b/libguile/ports.h
index 80644898..a7fde39 100644
--- a/libguile/ports.h
+++ b/libguile/ports.h
@@ -362,9 +362,9 @@ SCM_API SCM scm_set_port_column_x (SCM port, SCM line);
SCM_API SCM scm_port_filename (SCM port);
SCM_API SCM scm_set_port_filename_x (SCM port, SCM filename);
-/* Port alist. */
-SCM_INTERNAL SCM scm_i_port_alist (SCM port);
-SCM_INTERNAL void scm_i_set_port_alist_x (SCM port, SCM alist);
+/* Port properties. */
+SCM_INTERNAL SCM scm_i_port_property (SCM port, SCM key);
+SCM_INTERNAL SCM scm_i_set_port_property_x (SCM port, SCM key, SCM value);
/* Implementation helpers for port printing functions. */
SCM_API int scm_port_print (SCM exp, SCM port, scm_print_state *);
diff --git a/libguile/read.c b/libguile/read.c
index c8db812..d1e1be3 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -2115,10 +2115,10 @@ SCM_DEFINE (scm_file_encoding, "file-encoding", 1, 0, 0,
/* Per-port read options.
- We store per-port read options in the 'port-read-options' key of the
- port's alist, which is stored in the internal port structure. The
- value stored in the alist is a single integer that contains a two-bit
- field for each read option.
+ We store per-port read options in the 'port-read-options' port
+ property, which is stored in the internal port structure. The value
+ stored is a single integer that contains a two-bit field for each
+ read option.
If a bit field contains READ_OPTION_INHERIT (3), that indicates that
the applicable value should be inherited from the corresponding
@@ -2128,7 +2128,7 @@ SCM_DEFINE (scm_file_encoding, "file-encoding", 1, 0, 0,
read option has been set per-port, its possible values are those in
'enum t_keyword_style'. */
-/* Key to read options in per-port alists. */
+/* Key to read options in port properties. */
SCM_SYMBOL (sym_port_read_options, "port-read-options");
/* Offsets of bit fields for each per-port override */
@@ -2153,12 +2153,11 @@ SCM_SYMBOL (sym_port_read_options, "port-read-options");
static void
set_port_read_option (SCM port, int option, int new_value)
{
- SCM alist, scm_read_options;
+ SCM scm_read_options;
unsigned int read_options;
new_value &= READ_OPTION_MASK;
- alist = scm_i_port_alist (port);
- scm_read_options = scm_assq_ref (alist, sym_port_read_options);
+ scm_read_options = scm_i_port_property (port, sym_port_read_options);
if (scm_is_unsigned_integer (scm_read_options, 0, READ_OPTIONS_MAX_VALUE))
read_options = scm_to_uint (scm_read_options);
else
@@ -2166,8 +2165,7 @@ set_port_read_option (SCM port, int option, int new_value)
read_options &= ~(READ_OPTION_MASK << option);
read_options |= new_value << option;
scm_read_options = scm_from_uint (read_options);
- alist = scm_assq_set_x (alist, sym_port_read_options, scm_read_options);
- scm_i_set_port_alist_x (port, alist);
+ scm_i_set_port_property_x (port, sym_port_read_options, scm_read_options);
}
/* Set OPTS and PORT's case-insensitivity according to VALUE. */
@@ -2202,11 +2200,10 @@ set_port_curly_infix_p (SCM port, scm_t_read_opts
*opts, int value)
static void
init_read_options (SCM port, scm_t_read_opts *opts)
{
- SCM alist, val, scm_read_options;
+ SCM val, scm_read_options;
unsigned int read_options, x;
- alist = scm_i_port_alist (port);
- scm_read_options = scm_assq_ref (alist, sym_port_read_options);
+ scm_read_options = scm_i_port_property (port, sym_port_read_options);
if (scm_is_unsigned_integer (scm_read_options, 0, READ_OPTIONS_MAX_VALUE))
read_options = scm_to_uint (scm_read_options);
diff --git a/libguile/threads.c b/libguile/threads.c
index a67f30b..f39bcc3 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -1875,6 +1875,22 @@ scm_pthread_cond_timedwait (scm_i_pthread_cond_t *cond,
#endif
+static void
+do_unlock_with_asyncs (void *data)
+{
+ scm_i_pthread_mutex_unlock ((scm_i_pthread_mutex_t *)data);
+ SCM_I_CURRENT_THREAD->block_asyncs--;
+}
+
+void
+scm_i_dynwind_pthread_mutex_lock_block_asyncs (scm_i_pthread_mutex_t *mutex)
+{
+ SCM_I_CURRENT_THREAD->block_asyncs++;
+ scm_i_scm_pthread_mutex_lock (mutex);
+ scm_dynwind_unwind_handler (do_unlock_with_asyncs, mutex,
+ SCM_F_WIND_EXPLICITLY);
+}
+
unsigned long
scm_std_usleep (unsigned long usecs)
{
diff --git a/libguile/threads.h b/libguile/threads.h
index d34e1ab..6db6c75 100644
--- a/libguile/threads.h
+++ b/libguile/threads.h
@@ -140,6 +140,7 @@ SCM_INTERNAL void scm_init_threads (void);
SCM_INTERNAL void scm_init_thread_procs (void);
SCM_INTERNAL void scm_init_threads_default_dynamic_state (void);
+SCM_INTERNAL void scm_i_dynwind_pthread_mutex_lock_block_asyncs
(scm_i_pthread_mutex_t *mutex);
SCM_API SCM scm_call_with_new_thread (SCM thunk, SCM handler);
SCM_API SCM scm_yield (void);
diff --git a/libguile/throw.c b/libguile/throw.c
index 4b1885e..244bcf1 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -442,7 +442,7 @@ scm_handle_by_throw (void *handler_data SCM_UNUSED, SCM
tag, SCM args)
}
SCM
-scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
+scm_ithrow (SCM key, SCM args, int no_return SCM_UNUSED)
{
return scm_throw (key, args);
}
diff --git a/libguile/throw.h b/libguile/throw.h
index 6cf6790..62592d2 100644
--- a/libguile/throw.h
+++ b/libguile/throw.h
@@ -79,7 +79,7 @@ SCM_API int scm_exit_status (SCM args);
SCM_API SCM scm_catch_with_pre_unwind_handler (SCM tag, SCM thunk, SCM
handler, SCM lazy_handler);
SCM_API SCM scm_catch (SCM tag, SCM thunk, SCM handler);
SCM_API SCM scm_with_throw_handler (SCM tag, SCM thunk, SCM handler);
-SCM_API SCM scm_ithrow (SCM key, SCM args, int noreturn);
+SCM_API SCM scm_ithrow (SCM key, SCM args, int no_return);
SCM_API SCM scm_throw (SCM key, SCM args);
SCM_INTERNAL void scm_init_throw (void);
diff --git a/module/Makefile.am b/module/Makefile.am
index 64ded63..beb1a99 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -213,6 +213,7 @@ ICE_9_SOURCES = \
ice-9/format.scm \
ice-9/futures.scm \
ice-9/getopt-long.scm \
+ ice-9/hash-table.scm \
ice-9/hcons.scm \
ice-9/i18n.scm \
ice-9/iconv.scm \
diff --git a/module/ice-9/hash-table.scm b/module/ice-9/hash-table.scm
new file mode 100644
index 0000000..ca9d2fd
--- /dev/null
+++ b/module/ice-9/hash-table.scm
@@ -0,0 +1,45 @@
+;;;; hash-table.scm --- Additional hash table procedures
+;;;; Copyright (C) 2013 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+;;;;
+
+(define-module (ice-9 hash-table)
+ #:export (alist->hash-table
+ alist->hashq-table
+ alist->hashv-table
+ alist->hashx-table))
+
+(define-syntax-rule (define-alist-converter name hash-set-proc)
+ (define (name alist)
+ "Convert ALIST into a hash table."
+ (let ((table (make-hash-table)))
+ (for-each (lambda (pair)
+ (hash-set-proc table (car pair) (cdr pair)))
+ (reverse alist))
+ table)))
+
+(define-alist-converter alist->hash-table hash-set!)
+(define-alist-converter alist->hashq-table hashq-set!)
+(define-alist-converter alist->hashv-table hashv-set!)
+
+(define (alist->hashx-table hash assoc alist)
+ "Convert ALIST into a hash table with custom HASH and ASSOC
+procedures."
+ (let ((table (make-hash-table)))
+ (for-each (lambda (pair)
+ (hashx-set! hash assoc table (car pair) (cdr pair)))
+ (reverse alist))
+ table))
diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm
index 7d0549e..48a52e6 100644
--- a/module/ice-9/popen.scm
+++ b/module/ice-9/popen.scm
@@ -1,6 +1,7 @@
;; popen emulation, for non-stdio based ports.
-;;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2006, 2010, 2011, 2012, 2013
Free Software Foundation, Inc.
+;;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2006, 2010, 2011, 2012,
+;;;; 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -18,6 +19,8 @@
;;;;
(define-module (ice-9 popen)
+ :use-module (ice-9 threads)
+ :use-module (srfi srfi-9)
:export (port/pid-table open-pipe* open-pipe close-pipe open-input-pipe
open-output-pipe open-input-output-pipe))
@@ -25,6 +28,11 @@
(load-extension (string-append "libguile-" (effective-version))
"scm_init_popen"))
+(define-record-type <pipe-info>
+ (make-pipe-info pid)
+ pipe-info?
+ (pid pipe-info-pid set-pipe-info-pid!))
+
(define (make-rw-port read-port write-port)
(make-soft-port
(vector
@@ -40,7 +48,10 @@
(define pipe-guardian (make-guardian))
;; a weak hash-table to store the process ids.
+;; XXX use of this table is deprecated. It is no longer used here, and
+;; is populated for backward compatibility only (since it is exported).
(define port/pid-table (make-weak-key-hash-table 31))
+(define port/pid-table-mutex (make-mutex))
(define (open-pipe* mode command . args)
"Executes the program @var{command} with optional arguments
@@ -56,9 +67,19 @@ port to the process is created: it should be the value of
(make-rw-port read-port write-port))
read-port
write-port
- (%make-void-port mode))))
- (pipe-guardian port)
- (hashq-set! port/pid-table port pid)
+ (%make-void-port mode)))
+ (pipe-info (make-pipe-info pid)))
+
+ ;; Guard the pipe-info instead of the port, so that we can still
+ ;; call 'waitpid' even if 'close-port' is called (which clears
+ ;; the port entry).
+ (pipe-guardian pipe-info)
+ (%set-port-property! port 'popen-pipe-info pipe-info)
+
+ ;; XXX populate port/pid-table for backward compatibility.
+ (with-mutex port/pid-table-mutex
+ (hashq-set! port/pid-table port pid))
+
port))))
(define (open-pipe command mode)
@@ -69,52 +90,46 @@ port to the process is created: it should be the value of
@code{OPEN_READ}, @code{OPEN_WRITE} or @code{OPEN_BOTH}."
(open-pipe* mode "/bin/sh" "-c" command))
-(define (fetch-pid port)
- (let ((pid (hashq-ref port/pid-table port)))
- (hashq-remove! port/pid-table port)
- pid))
-
-(define (close-process port/pid)
- (close-port (car port/pid))
- (cdr (waitpid (cdr port/pid))))
-
-;; for the background cleanup handler: just clean up without reporting
-;; errors. also avoids blocking the process: if the child isn't ready
-;; to be collected, puts it back into the guardian's live list so it
-;; can be tried again the next time the cleanup runs.
-(define (close-process-quietly port/pid)
- (catch 'system-error
- (lambda ()
- (close-port (car port/pid)))
- (lambda args #f))
- (catch 'system-error
- (lambda ()
- (let ((pid/status (waitpid (cdr port/pid) WNOHANG)))
- (cond ((= (car pid/status) 0)
- ;; not ready for collection
- (pipe-guardian (car port/pid))
- (hashq-set! port/pid-table
- (car port/pid) (cdr port/pid))))))
- (lambda args #f)))
+(define (fetch-pipe-info port)
+ (%port-property port 'popen-pipe-info))
+
+(define (close-process port pid)
+ (close-port port)
+ (cdr (waitpid pid)))
(define (close-pipe p)
"Closes the pipe created by @code{open-pipe}, then waits for the process
to terminate and returns its status value, @xref{Processes, waitpid}, for
information on how to interpret this value."
- (let ((pid (fetch-pid p)))
- (if (not pid)
- (error "close-pipe: pipe not in table"))
- (close-process (cons p pid))))
-
-(define reap-pipes
- (lambda ()
- (let loop ((p (pipe-guardian)))
- (cond (p
- ;; maybe removed already by close-pipe.
- (let ((pid (fetch-pid p)))
- (if pid
- (close-process-quietly (cons p pid))))
- (loop (pipe-guardian)))))))
+ (let ((pipe-info (fetch-pipe-info p)))
+ (unless pipe-info
+ (error "close-pipe: port not created by (ice-9 popen)"))
+ (let ((pid (pipe-info-pid pipe-info)))
+ (unless pid
+ (error "close-pipe: pid has already been cleared"))
+ ;; clear the pid to avoid repeated calls to 'waitpid'.
+ (set-pipe-info-pid! pipe-info #f)
+ (close-process p pid))))
+
+(define (reap-pipes)
+ (let loop ()
+ (let ((pipe-info (pipe-guardian)))
+ (when pipe-info
+ (let ((pid (pipe-info-pid pipe-info)))
+ ;; maybe 'close-pipe' was already called.
+ (when pid
+ ;; clean up without reporting errors. also avoids blocking
+ ;; the process: if the child isn't ready to be collected,
+ ;; puts it back into the guardian's live list so it can be
+ ;; tried again the next time the cleanup runs.
+ (catch 'system-error
+ (lambda ()
+ (let ((pid/status (waitpid pid WNOHANG)))
+ (if (zero? (car pid/status))
+ (pipe-guardian pipe-info) ; not ready for collection
+ (set-pipe-info-pid! pipe-info #f))))
+ (lambda args #f))))
+ (loop)))))
(add-hook! after-gc-hook reap-pipes)
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 3619412..eeffecf 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -3053,7 +3053,14 @@
((read-file
(lambda (fn dir k)
(let ((p (open-input-file
- (if (absolute-file-name? fn) fn (in-vicinity dir
fn)))))
+ (if (absolute-file-name? fn)
+ fn
+ (if dir
+ (in-vicinity dir fn)
+ (syntax-violation
+ 'include
+ "relative file name only allowed when the
include form is in a file"
+ x))))))
(let ((enc (file-encoding p)))
(set-port-encoding! p (let ((t enc)) (if t t "UTF-8")))
(let f ((x (read p)) (result '()))
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 4b66b8b..5368785 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -3056,9 +3056,15 @@
(define read-file
(lambda (fn dir k)
(let* ((p (open-input-file
- (if (absolute-file-name? fn)
- fn
- (in-vicinity dir fn))))
+ (cond ((absolute-file-name? fn)
+ fn)
+ (dir
+ (in-vicinity dir fn))
+ (else
+ (syntax-violation
+ 'include
+ "relative file name only allowed when the include
form is in a file"
+ x)))))
(enc (file-encoding p)))
;; Choose the input encoding deterministically.
diff --git a/module/rnrs/exceptions.scm b/module/rnrs/exceptions.scm
index 95d01df..52f5c25 100644
--- a/module/rnrs/exceptions.scm
+++ b/module/rnrs/exceptions.scm
@@ -1,6 +1,6 @@
;;; exceptions.scm --- The R6RS exceptions library
-;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -29,14 +29,61 @@
newline
display
filter
+ acons
+ assv-ref
+ throw
set-exception-printer!
with-throw-handler
*unspecified*
@@))
- (define raise (@@ (rnrs records procedural) r6rs-raise))
- (define raise-continuable
+ ;; When a native guile exception is caught by an R6RS exception
+ ;; handler, we convert it to an R6RS compound condition that includes
+ ;; not only the standard condition objects expected by R6RS code, but
+ ;; also a special &guile condition that preserves the original KEY and
+ ;; ARGS passed to the native Guile catch handler.
+
+ (define-condition-type &guile &condition
+ make-guile-condition guile-condition?
+ (key guile-condition-key)
+ (args guile-condition-args))
+
+ (define (default-guile-condition-converter key args)
+ (condition (make-serious-condition)
+ (guile-common-conditions key args)))
+
+ (define (guile-common-conditions key args)
+ (apply (case-lambda
+ ((subr msg margs . _)
+ (condition (make-who-condition subr)
+ (make-message-condition msg)
+ (make-irritants-condition margs)))
+ (_ (make-irritants-condition args)))
+ args))
+
+ (define (convert-guile-condition key args)
+ (let ((converter (assv-ref guile-condition-converters key)))
+ (condition (or (and converter (converter key args))
+ (default-guile-condition-converter key args))
+ ;; Preserve the original KEY and ARGS in the R6RS
+ ;; condition object.
+ (make-guile-condition key args))))
+
+ ;; If an R6RS exception handler chooses not to handle a given
+ ;; condition, it will re-raise the condition to pass it on to the next
+ ;; handler. If the condition was converted from a native Guile
+ ;; exception, we must re-raise using the native Guile facilities and
+ ;; the original exception KEY and ARGS. We arrange for this in
+ ;; 'raise' so that native Guile exception handlers will continue to
+ ;; work when mixed with R6RS code.
+
+ (define (raise obj)
+ (if (guile-condition? obj)
+ (apply throw (guile-condition-key obj) (guile-condition-args obj))
+ ((@@ (rnrs records procedural) r6rs-raise) obj)))
+ (define raise-continuable
(@@ (rnrs records procedural) r6rs-raise-continuable))
+
(define raise-object-wrapper?
(@@ (rnrs records procedural) raise-object-wrapper?))
(define raise-object-wrapper-obj
@@ -45,19 +92,22 @@
(@@ (rnrs records procedural) raise-object-wrapper-continuation))
(define (with-exception-handler handler thunk)
- (with-throw-handler 'r6rs:exception
+ (with-throw-handler #t
thunk
(lambda (key . args)
- (if (and (not (null? args))
- (raise-object-wrapper? (car args)))
- (let* ((cargs (car args))
- (obj (raise-object-wrapper-obj cargs))
- (continuation (raise-object-wrapper-continuation cargs))
- (handler-return (handler obj)))
- (if continuation
- (continuation handler-return)
- (raise (make-non-continuable-violation))))
- *unspecified*))))
+ (cond ((not (eq? key 'r6rs:exception))
+ (let ((obj (convert-guile-condition key args)))
+ (handler obj)
+ (raise (make-non-continuable-violation))))
+ ((and (not (null? args))
+ (raise-object-wrapper? (car args)))
+ (let* ((cargs (car args))
+ (obj (raise-object-wrapper-obj cargs))
+ (continuation (raise-object-wrapper-continuation cargs))
+ (handler-return (handler obj)))
+ (if continuation
+ (continuation handler-return)
+ (raise (make-non-continuable-violation)))))))))
(define-syntax guard0
(syntax-rules ()
@@ -143,4 +193,84 @@
(set-exception-printer! 'r6rs:exception exception-printer)
-)
+ ;; Guile condition converters
+ ;;
+ ;; Each converter is a procedure (converter KEY ARGS) that returns
+ ;; either an R6RS condition or #f. If #f is returned,
+ ;; 'default-guile-condition-converter' will be used.
+
+ (define (guile-syntax-violation-converter key args)
+ (apply (case-lambda
+ ((who what where form subform . extra)
+ (condition (make-syntax-violation form subform)
+ (make-who-condition who)
+ (make-message-condition what)))
+ (_ #f))
+ args))
+
+ (define (guile-lexical-violation-converter key args)
+ (condition (make-lexical-violation) (guile-common-conditions key args)))
+
+ (define (guile-assertion-violation-converter key args)
+ (condition (make-assertion-violation) (guile-common-conditions key args)))
+
+ (define (guile-undefined-violation-converter key args)
+ (condition (make-undefined-violation) (guile-common-conditions key args)))
+
+ (define (guile-implementation-restriction-converter key args)
+ (condition (make-implementation-restriction-violation)
+ (guile-common-conditions key args)))
+
+ (define (guile-error-converter key args)
+ (condition (make-error) (guile-common-conditions key args)))
+
+ (define (guile-system-error-converter key args)
+ (apply (case-lambda
+ ((subr msg msg-args errno . rest)
+ ;; XXX TODO we should return a more specific error
+ ;; (usually an I/O error) as expected by R6RS programs.
+ ;; Unfortunately this often requires the 'filename' (or
+ ;; other?) which is not currently provided by the native
+ ;; Guile exceptions.
+ (condition (make-error) (guile-common-conditions key args)))
+ (_ (guile-error-converter key args)))
+ args))
+
+ ;; TODO: Arrange to have the needed information included in native
+ ;; Guile I/O exceptions, and arrange here to convert them to the
+ ;; proper conditions. Remove the earlier exception conversion
+ ;; mechanism: search for 'with-throw-handler' in the 'rnrs'
+ ;; tree, e.g. 'with-i/o-filename-conditions' and
+ ;; 'with-i/o-port-error' in (rnrs io ports).
+
+ ;; XXX TODO: How should we handle the 'misc-error', 'vm-error', and
+ ;; 'signal' native Guile exceptions?
+
+ ;; XXX TODO: Should we handle the 'quit' exception specially?
+
+ ;; An alist mapping native Guile exception keys to converters.
+ (define guile-condition-converters
+ `((read-error . ,guile-lexical-violation-converter)
+ (syntax-error . ,guile-syntax-violation-converter)
+ (unbound-variable . ,guile-undefined-violation-converter)
+ (wrong-number-of-args . ,guile-assertion-violation-converter)
+ (wrong-type-arg . ,guile-assertion-violation-converter)
+ (keyword-argument-error . ,guile-assertion-violation-converter)
+ (out-of-range . ,guile-assertion-violation-converter)
+ (regular-expression-syntax . ,guile-assertion-violation-converter)
+ (program-error . ,guile-assertion-violation-converter)
+ (goops-error . ,guile-assertion-violation-converter)
+ (null-pointer-error . ,guile-assertion-violation-converter)
+ (system-error . ,guile-system-error-converter)
+ (host-not-found . ,guile-error-converter)
+ (getaddrinfo-error . ,guile-error-converter)
+ (no-data . ,guile-error-converter)
+ (no-recovery . ,guile-error-converter)
+ (try-again . ,guile-error-converter)
+ (stack-overflow . ,guile-implementation-restriction-converter)
+ (numerical-overflow . ,guile-implementation-restriction-converter)
+ (memory-allocation-error .
,guile-implementation-restriction-converter)))
+
+ (define (set-guile-condition-converter! key proc)
+ (set! guile-condition-converters
+ (acons key proc guile-condition-converters))))
diff --git a/module/web/http.scm b/module/web/http.scm
index af04259..6c9ab95 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -716,6 +716,8 @@ as an ordered alist."
(cond
((string=? s "GMT")
0)
+ ((string=? s "UTC")
+ 0)
((string-match? s ".dddd")
(let ((sign (case (string-ref s 0)
((#\+) +1)
diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test
index bcaa282..a839b68 100644
--- a/test-suite/tests/exceptions.test
+++ b/test-suite/tests/exceptions.test
@@ -18,18 +18,20 @@
(use-modules (test-suite lib))
-(define-macro (throw-test title result . exprs)
- `(pass-if ,title
- (equal? ,result
- (letrec ((stack '())
- (push (lambda (val)
- (set! stack (cons val stack)))))
- (begin ,@exprs)
- ;;(display ,title)
- ;;(display ": ")
- ;;(write (reverse stack))
- ;;(newline)
- (reverse stack)))))
+(define-syntax-parameter push
+ (lambda (stx)
+ (syntax-violation 'push "push used outside of throw-test" stx)))
+
+(define-syntax-rule (throw-test title result expr ...)
+ (pass-if title
+ (equal? result
+ (let ((stack '()))
+ (syntax-parameterize ((push (syntax-rules ()
+ ((push val)
+ (set! stack (cons val stack))))))
+ expr ...
+ ;;(format #t "~a: ~s~%" title (reverse stack))
+ (reverse stack))))))
(with-test-prefix "throw/catch"
diff --git a/test-suite/tests/hash.test b/test-suite/tests/hash.test
index 3bd4004..ad247f5 100644
--- a/test-suite/tests/hash.test
+++ b/test-suite/tests/hash.test
@@ -18,7 +18,8 @@
(define-module (test-suite test-numbers)
#:use-module (test-suite lib)
- #:use-module (ice-9 documentation))
+ #:use-module (ice-9 documentation)
+ #:use-module (ice-9 hash-table))
;;;
;;; hash
@@ -81,6 +82,41 @@
(write (make-hash-table 100)))))))
;;;
+;;; alist->hash-table
+;;;
+
+(with-test-prefix
+ "alist conversion"
+
+ (pass-if "alist->hash-table"
+ (let ((table (alist->hash-table '(("foo" . 1)
+ ("bar" . 2)
+ ("foo" . 3)))))
+ (and (= (hash-ref table "foo") 1)
+ (= (hash-ref table "bar") 2))))
+
+ (pass-if "alist->hashq-table"
+ (let ((table (alist->hashq-table '((foo . 1)
+ (bar . 2)
+ (foo . 3)))))
+ (and (= (hashq-ref table 'foo) 1)
+ (= (hashq-ref table 'bar) 2))))
+
+ (pass-if "alist->hashv-table"
+ (let ((table (alist->hashv-table '((1 . 1)
+ (2 . 2)
+ (1 . 3)))))
+ (and (= (hashv-ref table 1) 1)
+ (= (hashv-ref table 2) 2))))
+
+ (pass-if "alist->hashx-table"
+ (let ((table (alist->hashx-table hash assoc '((foo . 1)
+ (bar . 2)
+ (foo . 3)))))
+ (and (= (hashx-ref hash assoc table 'foo) 1)
+ (= (hashx-ref hash assoc table 'bar) 2)))))
+
+;;;
;;; usual set and reference
;;;
diff --git a/test-suite/tests/r6rs-exceptions.test
b/test-suite/tests/r6rs-exceptions.test
index 54a4ddb..8ad6bdc 100644
--- a/test-suite/tests/r6rs-exceptions.test
+++ b/test-suite/tests/r6rs-exceptions.test
@@ -1,6 +1,6 @@
-;;; r6rs-exceptions.test --- Test suite for R6RS (rnrs exceptions)
+;;; r6rs-exceptions.test --- Test suite for R6RS (rnrs exceptions) -*- scheme
-*-
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2013 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -20,6 +20,7 @@
(define-module (test-suite test-rnrs-exceptions)
:use-module ((rnrs conditions) :version (6))
:use-module ((rnrs exceptions) :version (6))
+ :use-module (system foreign)
:use-module (test-suite lib))
(with-test-prefix "with-exception-handler"
@@ -96,3 +97,60 @@
(pass-if "guard with cond => syntax"
(guard (condition (condition => error?)) (raise (make-error)))))
+
+(with-test-prefix "guile condition conversions"
+
+ (define-syntax-rule (pass-if-condition name expected-condition? body ...)
+ (pass-if name
+ (guard (obj ((expected-condition? obj) #t)
+ (else #f))
+ body ... #f)))
+
+ (pass-if "rethrown native guile exceptions"
+ (catch #t
+ (lambda ()
+ (guard (obj ((syntax-violation? obj) #f))
+ (vector-ref '#(0 1) 2)
+ #f))
+ (lambda (key . args)
+ (eq? key 'out-of-range))))
+
+ (pass-if-condition "syntax-error"
+ syntax-violation?
+ (eval '(let) (current-module)))
+
+ (pass-if-condition "unbound-variable"
+ undefined-violation?
+ variable-that-does-not-exist)
+
+ (pass-if-condition "out-of-range"
+ assertion-violation?
+ (vector-ref '#(0 1) 2))
+
+ (pass-if-condition "wrong-number-of-args"
+ assertion-violation?
+ ((lambda () #f) 'unwanted-argument))
+
+ (pass-if-condition "wrong-type-arg"
+ assertion-violation?
+ (vector-ref '#(0 1) 'invalid-index))
+
+ (pass-if-condition "keyword-argument-error"
+ assertion-violation?
+ ((lambda* (#:key a) #f) #:unwanted-keyword 'val))
+
+ (pass-if-condition "regular-expression-syntax"
+ assertion-violation?
+ (make-regexp "[missing-close-square-bracket"))
+
+ (pass-if-condition "null-pointer-error"
+ assertion-violation?
+ (dereference-pointer (make-pointer 0)))
+
+ (pass-if-condition "read-error"
+ lexical-violation?
+ (read (open-input-string "(missing-close-paren"))))
+
+;;; Local Variables:
+;;; eval: (put 'pass-if-condition 'scheme-indent-function 1)
+;;; End:
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-509-gfcd953f,
Andy Wingo <=