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 <[email protected]> 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 <[email protected]> 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}. +@node SRFI-111 +@subsection SRFI-111 Boxes. +@cindex SRFI-111 + +@uref{http://srfi.schemers.org/srfi-111/srfi-111.html, SRFI-111} +provides boxes: objects with a single mutable cell. + +@deffn {Scheme Procedure} box value +Return a newly allocated box whose contents is initialized to +@var{value}. +@end deffn + +@deffn {Scheme Procedure} box? obj +Return true if @var{obj} is a box, otherwise return false. +@end deffn + +@deffn {Scheme Procedure} unbox box +Return the current contents of @var{box}. +@end deffn + +@deffn {Scheme Procedure} set-box! box value +Set the contents of @var{box} to @var{value}. +@end 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
