[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.9-171-g3e2e4
|
From: |
Mark H Weaver |
|
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.9-171-g3e2e496 |
|
Date: |
Fri, 24 Jan 2014 15:53:34 +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=3e2e49650c7360f7bba03219943334e2eabd3d91
The branch, stable-2.0 has been updated
via 3e2e49650c7360f7bba03219943334e2eabd3d91 (commit)
via 60617d819d77a1b92ed6c557a0b49b8e9a8e97b9 (commit)
from f6ddf827f8f192af7a8cd255bd8374a0d38bbb74 (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 3e2e49650c7360f7bba03219943334e2eabd3d91
Author: Mark H Weaver <address@hidden>
Date: Fri Jan 24 00:21:17 2014 -0500
Implement SRFI-111 Boxes.
* module/srfi/srfi-111.scm: New file.
* module/Makefile.am (SRFI_SOURCES): Add srfi/srfi-111.scm.
* test-suite/tests/srfi-111.test: New file.
* test-suite/Makefile.am (SCM_TESTS): Add tests/srfi-111.test.
* doc/ref/srfi-modules.texi (SRFI-111): New node.
commit 60617d819d77a1b92ed6c557a0b49b8e9a8e97b9
Author: Mark H Weaver <address@hidden>
Date: Thu Jan 23 11:37:36 2014 -0500
Fix thread-unsafe lazy initializations.
* libguile/backtrace.c (print_exception_var): New static variable.
(init_print_exception_var): New static function.
(scm_print_exception): Remove thread-unsafe lazy initialization.
Call 'init_print_exception_var' using 'scm_i_pthread_once'.
Use 'print_exception_var'.
* libguile/continuations.c (call_cc): New static variable.
(init_call_cc): New static function.
(scm_i_call_with_current_continuation): Remove thread-unsafe lazy
initialization. Call 'init_call_cc' using 'scm_i_pthread_once'.
* libguile/debug.c (local_eval_var): New static variable.
(init_local_eval_var): New static function.
(scm_local_eval): Remove lazy initialization using mutexes.
Call 'init_local_eval_var' using 'scm_i_pthread_once'.
Use 'scm_variable_ref' instead of 'SCM_VARIABLE_REF'.
* libguile/eval.c (map_var, for_each_var): New static variables.
(init_map_var, init_for_each_var): New static functions.
(scm_map, scm_for_each): Remove thread-unsafe lazy initializations.
Call 'init_map_var' (or 'init_for_each_var') using 'scm_i_pthread_once'.
Use 'map_var' (or 'for_each_var').
* libguile/frames.c (frame_arguments_var): New static variable.
(init_frame_arguments_var): New static function.
(scm_frame_arguments): Remove thread-unsafe lazy initialization.
Call 'init_frame_arguments_var' using 'scm_i_pthread_once'.
Use 'frame_arguments_var'. Use 'scm_variable_ref' instead of
'SCM_VARIABLE_REF'.
* libguile/goops.c (delayed_compile_var): New static variable.
(init_delayed_compile_var): New static function.
(make_dispatch_procedure): Remove thread-unsafe lazy initialization.
Call 'init_delayed_compile_var' using 'scm_i_pthread_once'.
Use 'delayed_compile_var'. Use 'scm_variable_ref' instead of
'SCM_VARIABLE_REF'.
* libguile/instructions.c (instructions_by_name): New static variable.
(init_instructions_by_name): New static function.
(scm_lookup_instruction_by_name): Remove thread-unsafe lazy
initialization. Call 'init_instructions_by_name' using
'scm_i_pthread_once'.
* libguile/ports.c (current_warning_port_var)
(current_warning_port_once): New static variables.
(init_current_warning_port_var): New static function.
(scm_current_warning_port): Remove lazy initialization using mutexes.
Call 'init_current_warning_port_var' using 'scm_i_pthread_once'.
Use 'current_warning_port_var'.
(scm_set_current_warning_port): Remove thread-unsafe lazy initialization.
Call 'init_current_warning_port_var' using 'scm_i_pthread_once'.
Use 'current_warning_port_var'.
* libguile/strings.c (null_stringbuf): New static variable.
(init_null_stringbuf): New static function.
(scm_i_make_string): Remove thread-unsafe lazy initialization.
Call 'init_null_stringbuf' using 'scm_i_pthread_once'.
* libguile/strports.c (eval_string_var, k_module): New static variables.
(init_eval_string_var_and_k_module): New static function.
(scm_eval_string_in_module): Remove lazy initialization using mutexes.
Call 'init_eval_string_var_and_k_module' using 'scm_i_pthread_once'.
Use 'eval_string_var'.
* libguile/throw.c (CACHE_VAR): Remove incorrect macro.
(catch_var, throw_var, with_throw_handler_var): New static variables.
(scm_catch, scm_catch_with_pre_unwind_handler): Remove thread-unsafe
lazy initialization. Use 'catch_var'.
(init_with_throw_handler_var): New static function.
(scm_with_throw_handler): Remove thread-unsafe lazy initialization.
Call 'init_with_throw_handler_var' using 'scm_i_pthread_once'.
Use 'with_throw_handler_var'.
(scm_throw): Remove thread-unsafe lazy initialization.
Use 'throw_var'.
(scm_init_throw): Initialize 'catch_var' and 'throw_var'.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/srfi-modules.texi | 25 +++++++++++
libguile/backtrace.c | 20 ++++++---
libguile/continuations.c | 14 +++++--
libguile/debug.c | 20 +++++----
libguile/eval.c | 31 +++++++++-----
libguile/frames.c | 20 ++++++---
libguile/goops.c | 19 ++++++---
libguile/instructions.c | 32 +++++++++------
libguile/ports.c | 32 +++++++-------
libguile/strings.c | 17 +++++---
libguile/strports.c | 25 ++++++-----
libguile/throw.c | 48 ++++++++++------------
module/Makefile.am | 3 +-
module/srfi/{srfi-2.scm => srfi-111.scm} | 34 +++++++++------
test-suite/Makefile.am | 1 +
test-suite/tests/srfi-111.test | 65 ++++++++++++++++++++++++++++++
16 files changed, 274 insertions(+), 132 deletions(-)
copy module/srfi/{srfi-2.scm => srfi-111.scm} (56%)
create mode 100644 test-suite/tests/srfi-111.test
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 66d5bd1..8845c85 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -59,6 +59,7 @@ get the relevant SRFI documents from the SRFI home page
* SRFI-88:: Keyword objects.
* SRFI-98:: Accessing environment variables.
* SRFI-105:: Curly-infix expressions.
+* SRFI-111:: Boxes.
@end menu
@@ -5181,6 +5182,30 @@ directive @code{#!curly-infix-and-bracket-lists}. For
example:
For more information on reader options, @xref{Scheme Read}.
address@hidden SRFI-111
address@hidden SRFI-111 Boxes.
address@hidden SRFI-111
+
address@hidden://srfi.schemers.org/srfi-111/srfi-111.html, SRFI-111}
+provides boxes: objects with a single mutable cell.
+
address@hidden {Scheme Procedure} box value
+Return a newly allocated box whose contents is initialized to
address@hidden
address@hidden deffn
+
address@hidden {Scheme Procedure} box? obj
+Return true if @var{obj} is a box, otherwise return false.
address@hidden deffn
+
address@hidden {Scheme Procedure} unbox box
+Return the current contents of @var{box}.
address@hidden deffn
+
address@hidden {Scheme Procedure} set-box! box value
+Set the contents of @var{box} to @var{value}.
address@hidden deffn
+
@c srfi-modules.texi ends here
@c Local Variables:
diff --git a/libguile/backtrace.c b/libguile/backtrace.c
index 7dd66ad..b0dc0f1 100644
--- a/libguile/backtrace.c
+++ b/libguile/backtrace.c
@@ -67,24 +67,30 @@ boot_print_exception (SCM port, SCM frame, SCM key, SCM
args)
}
#undef FUNC_NAME
+static SCM print_exception_var;
+
+static void
+init_print_exception_var (void)
+{
+ print_exception_var
+ = scm_module_variable (scm_the_root_module (),
+ scm_from_latin1_symbol ("print-exception"));
+}
+
SCM
scm_print_exception (SCM port, SCM frame, SCM key, SCM args)
#define FUNC_NAME "print-exception"
{
- static SCM print_exception = SCM_BOOL_F;
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+ scm_i_pthread_once (&once, init_print_exception_var);
SCM_VALIDATE_OPOUTPORT (1, port);
if (scm_is_true (frame))
SCM_VALIDATE_FRAME (2, frame);
SCM_VALIDATE_SYMBOL (3, key);
SCM_VALIDATE_LIST (4, args);
-
- if (scm_is_false (print_exception))
- print_exception =
- scm_module_variable (scm_the_root_module (),
- scm_from_latin1_symbol ("print-exception"));
- return scm_call_4 (scm_variable_ref (print_exception),
+ return scm_call_4 (scm_variable_ref (print_exception_var),
port, frame, key, args);
}
#undef FUNC_NAME
diff --git a/libguile/continuations.c b/libguile/continuations.c
index d991278..ad8885a 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -236,14 +236,20 @@ scm_i_make_continuation (int *first, SCM vm, SCM vm_cont)
}
#undef FUNC_NAME
+static SCM call_cc;
+
+static void
+init_call_cc (void)
+{
+ call_cc = scm_make_program (call_cc_objcode, SCM_BOOL_F, SCM_BOOL_F);
+}
+
SCM
scm_i_call_with_current_continuation (SCM proc)
{
- static SCM call_cc = SCM_BOOL_F;
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+ scm_i_pthread_once (&once, init_call_cc);
- if (scm_is_false (call_cc))
- call_cc = scm_make_program (call_cc_objcode, SCM_BOOL_F, SCM_BOOL_F);
-
return scm_call_1 (call_cc, proc);
}
diff --git a/libguile/debug.c b/libguile/debug.c
index 9e6328b..107b5d4 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -208,19 +208,21 @@ SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0,
#undef FUNC_NAME
#endif
+static SCM local_eval_var;
+
+static void
+init_local_eval_var (void)
+{
+ local_eval_var = scm_c_public_variable ("ice-9 local-eval", "local-eval");
+}
+
SCM
scm_local_eval (SCM exp, SCM env)
{
- static SCM local_eval_var = SCM_UNDEFINED;
- static scm_i_pthread_mutex_t local_eval_var_mutex
- = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-
- scm_i_scm_pthread_mutex_lock (&local_eval_var_mutex);
- if (SCM_UNBNDP (local_eval_var))
- local_eval_var = scm_c_public_variable ("ice-9 local-eval", "local-eval");
- scm_i_pthread_mutex_unlock (&local_eval_var_mutex);
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+ scm_i_pthread_once (&once, init_local_eval_var);
- return scm_call_2 (SCM_VARIABLE_REF (local_eval_var), exp, env);
+ return scm_call_2 (scm_variable_ref (local_eval_var), exp, env);
}
static void
diff --git a/libguile/eval.c b/libguile/eval.c
index 6047d6d..815f7c7 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -642,30 +642,37 @@ SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0,
}
#undef FUNC_NAME
+static SCM map_var, for_each_var;
+
+static void init_map_var (void)
+{
+ map_var = scm_private_variable (scm_the_root_module (),
+ scm_from_latin1_symbol ("map"));
+}
+
+static void init_for_each_var (void)
+{
+ for_each_var = scm_private_variable (scm_the_root_module (),
+ scm_from_latin1_symbol ("for-each"));
+}
SCM
scm_map (SCM proc, SCM arg1, SCM args)
{
- static SCM var = SCM_BOOL_F;
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+ scm_i_pthread_once (&once, init_map_var);
- if (scm_is_false (var))
- var = scm_private_variable (scm_the_root_module (),
- scm_from_latin1_symbol ("map"));
-
- return scm_apply (scm_variable_ref (var),
+ return scm_apply (scm_variable_ref (map_var),
scm_cons (proc, scm_cons (arg1, args)), SCM_EOL);
}
SCM
scm_for_each (SCM proc, SCM arg1, SCM args)
{
- static SCM var = SCM_BOOL_F;
-
- if (scm_is_false (var))
- var = scm_private_variable (scm_the_root_module (),
- scm_from_latin1_symbol ("for-each"));
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+ scm_i_pthread_once (&once, init_for_each_var);
- return scm_apply (scm_variable_ref (var),
+ return scm_apply (scm_variable_ref (for_each_var),
scm_cons (proc, scm_cons (arg1, args)), SCM_EOL);
}
diff --git a/libguile/frames.c b/libguile/frames.c
index a7143c4..9e77908 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -82,20 +82,26 @@ SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0,
}
#undef FUNC_NAME
+static SCM frame_arguments_var;
+
+static void
+init_frame_arguments_var (void)
+{
+ frame_arguments_var
+ = scm_c_private_lookup ("system vm frame", "frame-arguments");
+}
+
SCM_DEFINE (scm_frame_arguments, "frame-arguments", 1, 0, 0,
(SCM frame),
"")
#define FUNC_NAME s_scm_frame_arguments
{
- static SCM var = SCM_BOOL_F;
-
- SCM_VALIDATE_VM_FRAME (1, frame);
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+ scm_i_pthread_once (&once, init_frame_arguments_var);
- if (scm_is_false (var))
- var = scm_c_module_lookup (scm_c_resolve_module ("system vm frame"),
- "frame-arguments");
+ SCM_VALIDATE_VM_FRAME (1, frame);
- return scm_call_1 (SCM_VARIABLE_REF (var), frame);
+ return scm_call_1 (scm_variable_ref (frame_arguments_var), frame);
}
#undef FUNC_NAME
diff --git a/libguile/goops.c b/libguile/goops.c
index 9a40277..4a2e24d 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -1763,15 +1763,22 @@ scm_call_generic_3 (SCM gf, SCM a1, SCM a2, SCM a3)
return scm_call_3 (SCM_STRUCT_PROCEDURE (gf), a1, a2, a3);
}
-SCM_SYMBOL (sym_delayed_compile, "delayed-compile");
+static SCM delayed_compile_var;
+
+static void
+init_delayed_compile_var (void)
+{
+ delayed_compile_var
+ = scm_c_private_lookup ("oop goops dispatch", "delayed-compile");
+}
+
static SCM
make_dispatch_procedure (SCM gf)
{
- static SCM var = SCM_BOOL_F;
- if (scm_is_false (var))
- var = scm_module_variable (scm_c_resolve_module ("oop goops dispatch"),
- sym_delayed_compile);
- return scm_call_1 (SCM_VARIABLE_REF (var), gf);
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+ scm_i_pthread_once (&once, init_delayed_compile_var);
+
+ return scm_call_1 (scm_variable_ref (delayed_compile_var), gf);
}
static void
diff --git a/libguile/instructions.c b/libguile/instructions.c
index ef4a9ce..30a47cf 100644
--- a/libguile/instructions.c
+++ b/libguile/instructions.c
@@ -82,25 +82,31 @@ fetch_instruction_table ()
return table;
}
+static SCM instructions_by_name;
+
+static void
+init_instructions_by_name (void)
+{
+ struct scm_instruction *table = fetch_instruction_table ();
+ unsigned int i;
+
+ instructions_by_name =
+ scm_make_hash_table (SCM_I_MAKINUM (SCM_VM_NUM_INSTRUCTIONS));
+
+ for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
+ if (scm_is_true (table[i].symname))
+ scm_hashq_set_x (instructions_by_name, table[i].symname,
+ SCM_I_MAKINUM (i));
+}
+
static struct scm_instruction *
scm_lookup_instruction_by_name (SCM name)
{
- static SCM instructions_by_name = SCM_BOOL_F;
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
struct scm_instruction *table = fetch_instruction_table ();
SCM op;
- if (SCM_UNLIKELY (scm_is_false (instructions_by_name)))
- {
- unsigned int i;
-
- instructions_by_name =
- scm_make_hash_table (SCM_I_MAKINUM (SCM_VM_NUM_INSTRUCTIONS));
-
- for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
- if (scm_is_true (table[i].symname))
- scm_hashq_set_x (instructions_by_name, table[i].symname,
- SCM_I_MAKINUM (i));
- }
+ scm_i_pthread_once (&once, init_instructions_by_name);
op = scm_hashq_ref (instructions_by_name, name, SCM_UNDEFINED);
if (SCM_I_INUMP (op))
diff --git a/libguile/ports.c b/libguile/ports.c
index 4f401de..720ffc1 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -454,19 +454,22 @@ SCM_DEFINE (scm_current_error_port, "current-error-port",
0, 0, 0,
}
#undef FUNC_NAME
+static SCM current_warning_port_var;
+static scm_i_pthread_once_t current_warning_port_once =
SCM_I_PTHREAD_ONCE_INIT;
+
+static void
+init_current_warning_port_var (void)
+{
+ current_warning_port_var
+ = scm_c_private_variable ("guile", "current-warning-port");
+}
+
SCM
scm_current_warning_port (void)
{
- static SCM cwp_var = SCM_UNDEFINED;
- static scm_i_pthread_mutex_t cwp_var_mutex
- = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-
- scm_i_scm_pthread_mutex_lock (&cwp_var_mutex);
- if (SCM_UNBNDP (cwp_var))
- cwp_var = scm_c_private_variable ("guile", "current-warning-port");
- scm_i_pthread_mutex_unlock (&cwp_var_mutex);
-
- return scm_call_0 (scm_variable_ref (cwp_var));
+ scm_i_pthread_once (¤t_warning_port_once,
+ init_current_warning_port_var);
+ return scm_call_0 (scm_variable_ref (current_warning_port_var));
}
SCM_DEFINE (scm_current_load_port, "current-load-port", 0, 0, 0,
@@ -527,12 +530,9 @@ SCM_DEFINE (scm_set_current_error_port,
"set-current-error-port", 1, 0, 0,
SCM
scm_set_current_warning_port (SCM port)
{
- static SCM cwp_var = SCM_BOOL_F;
-
- if (scm_is_false (cwp_var))
- cwp_var = scm_c_private_lookup ("guile", "current-warning-port");
-
- return scm_call_1 (scm_variable_ref (cwp_var), port);
+ scm_i_pthread_once (¤t_warning_port_once,
+ init_current_warning_port_var);
+ return scm_call_1 (scm_variable_ref (current_warning_port_var), port);
}
diff --git a/libguile/strings.c b/libguile/strings.c
index 1b241e5..cab5d05 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -260,6 +260,15 @@ scm_i_pthread_mutex_t stringbuf_write_mutex =
SCM_I_PTHREAD_MUTEX_INITIALIZER;
SCM scm_nullstr;
+static SCM null_stringbuf;
+
+static void
+init_null_stringbuf (void)
+{
+ null_stringbuf = make_stringbuf (0);
+ SET_STRINGBUF_SHARED (null_stringbuf);
+}
+
/* Create a scheme string with space for LEN 8-bit Latin-1-encoded
characters. CHARSP, if not NULL, will be set to location of the
char array. If READ_ONLY_P, the returned string is read-only;
@@ -267,17 +276,13 @@ SCM scm_nullstr;
SCM
scm_i_make_string (size_t len, char **charsp, int read_only_p)
{
- static SCM null_stringbuf = SCM_BOOL_F;
SCM buf;
SCM res;
if (len == 0)
{
- if (SCM_UNLIKELY (scm_is_false (null_stringbuf)))
- {
- null_stringbuf = make_stringbuf (0);
- SET_STRINGBUF_SHARED (null_stringbuf);
- }
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+ scm_i_pthread_once (&once, init_null_stringbuf);
buf = null_stringbuf;
}
else
diff --git a/libguile/strports.c b/libguile/strports.c
index d1b293c..582b5e9 100644
--- a/libguile/strports.c
+++ b/libguile/strports.c
@@ -523,6 +523,16 @@ scm_c_eval_string_in_module (const char *expr, SCM module)
}
+static SCM eval_string_var;
+static SCM k_module;
+
+static void
+init_eval_string_var_and_k_module (void)
+{
+ eval_string_var = scm_c_public_variable ("ice-9 eval-string", "eval-string");
+ k_module = scm_from_locale_keyword ("module");
+}
+
SCM_DEFINE (scm_eval_string_in_module, "eval-string", 1, 1, 0,
(SCM string, SCM module),
"Evaluate @var{string} as the text representation of a Scheme\n"
@@ -534,23 +544,16 @@ SCM_DEFINE (scm_eval_string_in_module, "eval-string", 1,
1, 0,
"procedure returns.")
#define FUNC_NAME s_scm_eval_string_in_module
{
- static SCM eval_string = SCM_UNDEFINED, k_module = SCM_UNDEFINED;
- static scm_i_pthread_mutex_t init_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
-
- scm_i_scm_pthread_mutex_lock (&init_mutex);
- if (SCM_UNBNDP (eval_string))
- {
- eval_string = scm_c_public_variable ("ice-9 eval-string", "eval-string");
- k_module = scm_from_locale_keyword ("module");
- }
- scm_i_pthread_mutex_unlock (&init_mutex);
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+ scm_i_pthread_once (&once, init_eval_string_var_and_k_module);
if (SCM_UNBNDP (module))
module = scm_current_module ();
else
SCM_VALIDATE_MODULE (2, module);
- return scm_call_3 (scm_variable_ref (eval_string), string, k_module, module);
+ return scm_call_3 (scm_variable_ref (eval_string_var),
+ string, k_module, module);
}
#undef FUNC_NAME
diff --git a/libguile/throw.c b/libguile/throw.c
index 7fc9edf..663a48b 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -53,24 +53,14 @@
baggage. */
-#define CACHE_VAR(var,name) \
- static SCM var = SCM_BOOL_F; \
- if (scm_is_false (var)) \
- { \
- var = scm_module_variable (scm_the_root_module (), \
- scm_from_latin1_symbol (name)); \
- if (scm_is_false (var)) \
- abort (); \
- }
-
+static SCM catch_var, throw_var, with_throw_handler_var;
+
SCM
scm_catch (SCM key, SCM thunk, SCM handler)
{
- CACHE_VAR (var, "catch");
-
- return scm_call_3 (scm_variable_ref (var), key, thunk, handler);
+ return scm_call_3 (scm_variable_ref (catch_var), key, thunk, handler);
}
SCM
@@ -80,28 +70,32 @@ scm_catch_with_pre_unwind_handler (SCM key, SCM thunk, SCM
handler,
if (SCM_UNBNDP (pre_unwind_handler))
return scm_catch (key, thunk, handler);
else
- {
- CACHE_VAR (var, "catch");
-
- return scm_call_4 (scm_variable_ref (var), key, thunk, handler,
- pre_unwind_handler);
- }
+ return scm_call_4 (scm_variable_ref (catch_var), key, thunk, handler,
+ pre_unwind_handler);
+}
+
+static void
+init_with_throw_handler_var (void)
+{
+ with_throw_handler_var
+ = scm_module_variable (scm_the_root_module (),
+ scm_from_latin1_symbol ("with-throw-handler"));
}
SCM
scm_with_throw_handler (SCM key, SCM thunk, SCM handler)
{
- CACHE_VAR (var, "with-throw-handler");
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+ scm_i_pthread_once (&once, init_with_throw_handler_var);
- return scm_call_3 (scm_variable_ref (var), key, thunk, handler);
+ return scm_call_3 (scm_variable_ref (with_throw_handler_var),
+ key, thunk, handler);
}
SCM
scm_throw (SCM key, SCM args)
{
- CACHE_VAR (var, "throw");
-
- return scm_apply_1 (scm_variable_ref (var), key, args);
+ return scm_apply_1 (scm_variable_ref (throw_var), key, args);
}
@@ -534,8 +528,10 @@ scm_init_throw ()
tc16_catch_closure = scm_make_smob_type ("catch-closure", 0);
scm_set_smob_apply (tc16_catch_closure, apply_catch_closure, 0, 0, 1);
- scm_c_define ("catch", scm_c_make_gsubr ("catch", 3, 1, 0, pre_init_catch));
- scm_c_define ("throw", scm_c_make_gsubr ("throw", 1, 0, 1, pre_init_throw));
+ catch_var = scm_c_define ("catch", scm_c_make_gsubr ("catch", 3, 1, 0,
+ pre_init_catch));
+ throw_var = scm_c_define ("throw", scm_c_make_gsubr ("throw", 1, 0, 1,
+ pre_init_throw));
#include "libguile/throw.x"
}
diff --git a/module/Makefile.am b/module/Makefile.am
index 8a7befd..47b9c2c 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -295,7 +295,8 @@ SRFI_SOURCES = \
srfi/srfi-67.scm \
srfi/srfi-69.scm \
srfi/srfi-88.scm \
- srfi/srfi-98.scm
+ srfi/srfi-98.scm \
+ srfi/srfi-111.scm
RNRS_SOURCES = \
rnrs/base.scm \
diff --git a/module/srfi/srfi-2.scm b/module/srfi/srfi-111.scm
similarity index 56%
copy from module/srfi/srfi-2.scm
copy to module/srfi/srfi-111.scm
index c09323f..3d3cd89 100644
--- a/module/srfi/srfi-2.scm
+++ b/module/srfi/srfi-111.scm
@@ -1,31 +1,37 @@
-;;; srfi-2.scm --- and-let*
+;;; srfi-111.scm -- SRFI 111 Boxes
-;; Copyright (C) 2001, 2002, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2014 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
-;;; Commentary:
-
-;; This module is fully documented in the Guile Reference Manual.
-
-;;; Code:
+(define-module (srfi srfi-111)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:export (box box? unbox set-box!))
-(define-module (srfi srfi-2)
- :use-module (ice-9 and-let-star)
- :re-export-syntax (and-let*))
+(cond-expand-provide (current-module) '(srfi-111))
-(cond-expand-provide (current-module) '(srfi-2))
+(define-record-type <box>
+ (box value)
+ box?
+ (value unbox set-box!))
-;;; srfi-2.scm ends here
+(set-record-type-printer! <box>
+ (lambda (box port)
+ (display "#<box " port)
+ (display (number->string (object-address box) 16) port)
+ (display " value: ")
+ (write (unbox box) port)
+ (display ">" port)))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 01ffd1c..00f62fe 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -139,6 +139,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-69.test \
tests/srfi-88.test \
tests/srfi-105.test \
+ tests/srfi-111.test \
tests/srfi-4.test \
tests/srfi-9.test \
tests/statprof.test \
diff --git a/test-suite/tests/srfi-111.test b/test-suite/tests/srfi-111.test
new file mode 100644
index 0000000..e2d76c6
--- /dev/null
+++ b/test-suite/tests/srfi-111.test
@@ -0,0 +1,65 @@
+;;;; srfi-111.test --- Test suite for SRFI-111 (Boxes). -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+(define-module (test-srfi-111)
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-111))
+
+(with-test-prefix "srfi-111"
+
+ (let ((test-vals '(#f #t #\space "string" -5 #e1e100 1e-30 #(a vector))))
+ (pass-if-equal "box and unbox"
+ test-vals
+ (map (lambda (x)
+ (unbox (box x)))
+ test-vals))
+
+ (pass-if "box?"
+ (and (box? (box 5))
+ (not (any box? test-vals))))
+
+ (pass-if-equal "set-box!"
+ "string"
+ (let ((b (box #f)))
+ (set-box! b "string")
+ (unbox b)))
+
+ (pass-if "eq? on boxes"
+ (let ((box1 (box #f))
+ (box2 (box #f)))
+ (and (eq? box1 box1)
+ (eq? box2 box2)
+ (not (eq? box1 box2)))))
+
+ (pass-if "eqv? on boxes"
+ (let ((box1 (box #f))
+ (box2 (box #f)))
+ (and (eqv? box1 box1)
+ (eqv? box2 box2)
+ (not (eqv? box1 box2)))))
+
+ (pass-if "equal? on boxes"
+ (let ((box1 (box "foo"))
+ (box2 (box "bar")))
+ (and (equal? box1 box1)
+ (equal? box2 box2)
+ (not (equal? box1 box2))
+ ;; Guile extension, not guaranteed by SRFI-111.
+ (begin (set-box! box2 (string #\f #\o #\o))
+ (equal? box1 box2)))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.9-171-g3e2e496,
Mark H Weaver <=