From 260f55adecc2e0a0c2e54e55f297f13df66307d2 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Fri, 20 Jan 2017 00:49:11 +0900 Subject: [PATCH] Use a context global instead of a static C global for the default random source. Fixes issue #385. --- include/chibi/sexp.h | 1 + lib/srfi/27/rand.c | 101 +++++++++++++++++++++++++------------------ 2 files changed, 59 insertions(+), 43 deletions(-) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index bc8311fc..8f9011e6 100755 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -1345,6 +1345,7 @@ enum sexp_context_globals { SEXP_G_ERR_HANDLER, SEXP_G_RESUMECC_BYTECODE, SEXP_G_FINAL_RESUMER, + SEXP_G_RANDOM_SOURCE, SEXP_G_STRICT_P, SEXP_G_NO_TAIL_CALLS_P, #if SEXP_USE_FOLD_CASE_SYMS diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c index 11eda9c7..ff09909e 100644 --- a/lib/srfi/27/rand.c +++ b/lib/srfi/27/rand.c @@ -1,5 +1,5 @@ /* rand.c -- rand_r/random_r interface */ -/* Copyright (c) 2009-2014 Alex Shinn. All rights reserved. */ +/* Copyright (c) 2009-2017 Alex Shinn. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ #include @@ -11,16 +11,13 @@ #define ONE sexp_make_fixnum(1) #define STATE_SIZE sexp_make_fixnum(SEXP_RANDOM_STATE_SIZE) -#define sexp_random_source_p(x) sexp_check_tag(x, rs_type_id) +#define sexp_random_source_p(self, x) (!self || ((sexp_pointerp(x) && (sexp_pointer_tag(x) == sexp_unbox_fixnum(sexp_opcode_arg1_type(self)))))) #define sexp_random_state(x) (sexp_slot_ref((x), 0)) #define sexp_random_data(x) ((sexp_random_t*)(&sexp_slot_ref((x), 1))) #define sexp_sizeof_random (sexp_sizeof_header + sizeof(sexp_random_t) + sizeof(sexp)) -static sexp_uint_t rs_type_id = 0; -static sexp default_random_source; - #ifdef __GNU_LIBRARY__ typedef struct random_data sexp_random_t; @@ -53,8 +50,8 @@ sexp sexp_rs_random_integer (sexp ctx, sexp self, sexp_sint_t n, sexp rs, sexp b sexp_uint32_t *data; sexp_int32_t hi, len, i; #endif - if (! sexp_random_source_p(rs)) - res = sexp_type_exception(ctx, self, rs_type_id, rs); + if (!sexp_random_source_p(self, rs)) + return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), rs); if (sexp_fixnump(bound)) { sexp_call_random(rs, m); res = sexp_make_fixnum(m % sexp_unbox_fixnum(bound)); @@ -101,40 +98,40 @@ sexp sexp_rs_random_integer (sexp ctx, sexp self, sexp_sint_t n, sexp rs, sexp b } sexp sexp_random_integer (sexp ctx, sexp self, sexp_sint_t n, sexp bound) { - return sexp_rs_random_integer(ctx, self, n, default_random_source, bound); + return sexp_rs_random_integer(ctx, self, n, sexp_global(ctx, SEXP_G_RANDOM_SOURCE), bound); } sexp sexp_rs_random_real (sexp ctx, sexp self, sexp_sint_t n, sexp rs) { sexp_int32_t res; - if (! sexp_random_source_p(rs)) - return sexp_type_exception(ctx, self, rs_type_id, rs); + if (!sexp_random_source_p(self, rs)) + return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), rs); sexp_call_random(rs, res); return sexp_make_flonum(ctx, (double)res / (double)RAND_MAX); } sexp sexp_random_real (sexp ctx, sexp self, sexp_sint_t n) { - return sexp_rs_random_real(ctx, self, n, default_random_source); + return sexp_rs_random_real(ctx, self, n, sexp_global(ctx, SEXP_G_RANDOM_SOURCE)); } #if SEXP_BSD || defined(__CYGWIN__) sexp sexp_make_random_source (sexp ctx, sexp self, sexp_sint_t n) { sexp res; - res = sexp_alloc_tagged(ctx, sexp_sizeof_random, rs_type_id); + res = sexp_alloc_tagged(ctx, sexp_sizeof_random, sexp_unbox_fixnum(sexp_opcode_return_type(self))); *sexp_random_data(res) = 1; return res; } sexp sexp_random_source_state_ref (sexp ctx, sexp self, sexp_sint_t n, sexp rs) { - if (! sexp_random_source_p(rs)) - return sexp_type_exception(ctx, self, rs_type_id, rs); + if (!sexp_random_source_p(self, rs)) + return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), rs); else return sexp_make_integer(ctx, *sexp_random_data(rs)); } sexp sexp_random_source_state_set (sexp ctx, sexp self, sexp_sint_t n, sexp rs, sexp state) { - if (! sexp_random_source_p(rs)) - return sexp_type_exception(ctx, self, rs_type_id, rs); + if (!sexp_random_source_p(self, rs)) + return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), rs); else if (sexp_fixnump(state)) *sexp_random_data(rs) = sexp_unbox_fixnum(state); #if SEXP_USE_BIGNUMS @@ -154,7 +151,7 @@ sexp sexp_make_random_source (sexp ctx, sexp self, sexp_sint_t n) { sexp_gc_var1(state); sexp_gc_preserve1(ctx, state); state = sexp_make_bytes(ctx, STATE_SIZE, SEXP_UNDEF); - res = sexp_alloc_tagged(ctx, sexp_sizeof_random, rs_type_id); + res = sexp_alloc_tagged(ctx, sexp_sizeof_random, sexp_opcode_return_type(self)); if (sexp_exceptionp(res)) return res; sexp_random_state(res) = state; sexp_random_init(res, 1); @@ -163,15 +160,15 @@ sexp sexp_make_random_source (sexp ctx, sexp self, sexp_sint_t n) { } sexp sexp_random_source_state_ref (sexp ctx, sexp self, sexp_sint_t n, sexp rs) { - if (! sexp_random_source_p(rs)) - return sexp_type_exception(ctx, self, rs_type_id, rs); + if (self && ! (sexp_pointerp(rs) && (sexp_pointer_tag(rs) == sexp_unbox_fixnum(sexp_opcode_arg1_type(self))))) + return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), rs); else return sexp_subbytes(ctx, sexp_random_state(rs), ZERO, STATE_SIZE); } sexp sexp_random_source_state_set (sexp ctx, sexp self, sexp_sint_t n, sexp rs, sexp state) { - if (! sexp_random_source_p(rs)) - return sexp_type_exception(ctx, self, rs_type_id, rs); + if (!sexp_random_source_p(self, rs)) + return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), rs); else if (! (sexp_bytesp(state) && (sexp_bytes_length(state) == SEXP_RANDOM_STATE_SIZE))) return sexp_type_exception(ctx, self, SEXP_BYTES, state); @@ -183,29 +180,30 @@ sexp sexp_random_source_state_set (sexp ctx, sexp self, sexp_sint_t n, sexp rs, #endif sexp sexp_random_source_randomize (sexp ctx, sexp self, sexp_sint_t n, sexp rs) { - if (! sexp_random_source_p(rs)) - return sexp_type_exception(ctx, self, rs_type_id, rs); + if (! sexp_random_source_p(self, rs)) + return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), rs); sexp_seed_random(time(NULL), rs); return SEXP_VOID; } sexp sexp_random_source_pseudo_randomize (sexp ctx, sexp self, sexp_sint_t n, sexp rs, sexp seed1, sexp seed2) { - if (! sexp_random_source_p(rs)) - return sexp_type_exception(ctx, self, rs_type_id, rs); + if (! sexp_random_source_p(self, rs)) + return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), rs); if (! sexp_fixnump(seed1)) - return sexp_type_exception(ctx, self, rs_type_id, seed1); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, seed1); if (! sexp_fixnump(seed2)) - return sexp_type_exception(ctx, self, rs_type_id, seed2); + return sexp_type_exception(ctx, self, SEXP_FIXNUM, seed2); sexp_seed_random(sexp_unbox_fixnum(seed1) ^ sexp_unbox_fixnum(seed2), rs); return SEXP_VOID; } sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, const sexp_abi_identifier_t abi) { - sexp_gc_var2(name, op); + sexp_uint_t rs_type_id; + sexp_gc_var3(name, op, make_op); if (!(sexp_version_compatible(ctx, version, sexp_version) && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER))) return SEXP_ABI_ERROR; - sexp_gc_preserve2(ctx, name, op); + sexp_gc_preserve3(ctx, name, op, make_op); name = sexp_c_string(ctx, "random-source", -1); op = sexp_register_type(ctx, name, SEXP_FALSE, SEXP_FALSE, @@ -222,22 +220,39 @@ sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char name = sexp_intern(ctx, "random-source?", -1); sexp_env_define(ctx, env, name, op); - sexp_define_foreign(ctx, env, "make-random-source", 0, sexp_make_random_source); - sexp_define_foreign(ctx, env, "%random-integer", 2, sexp_rs_random_integer); - sexp_define_foreign(ctx, env, "random-integer", 1, sexp_random_integer); - sexp_define_foreign(ctx, env, "%random-real", 1, sexp_rs_random_real); - sexp_define_foreign(ctx, env, "random-real", 0, sexp_random_real); - sexp_define_foreign(ctx, env, "random-source-state-ref", 1, sexp_random_source_state_ref); - sexp_define_foreign(ctx, env, "random-source-state-set!", 2, sexp_random_source_state_set); - sexp_define_foreign(ctx, env, "random-source-randomize!", 1, sexp_random_source_randomize); - sexp_define_foreign(ctx, env, "random-source-pseudo-randomize!", 3, sexp_random_source_pseudo_randomize); + make_op = sexp_define_foreign(ctx, env, "make-random-source", 0, sexp_make_random_source); + if (sexp_opcodep(make_op)) + sexp_opcode_return_type(make_op) = sexp_make_fixnum(rs_type_id); + op = sexp_define_foreign(ctx, env, "%random-integer", 2, sexp_rs_random_integer); + if (sexp_opcodep(op)) + sexp_opcode_arg1_type(op) = sexp_make_fixnum(rs_type_id); + op = sexp_define_foreign(ctx, env, "random-integer", 1, sexp_random_integer); + if (sexp_opcodep(op)) + sexp_opcode_arg1_type(op) = sexp_make_fixnum(rs_type_id); + op = sexp_define_foreign(ctx, env, "%random-real", 1, sexp_rs_random_real); + if (sexp_opcodep(op)) + sexp_opcode_arg1_type(op) = sexp_make_fixnum(rs_type_id); + op = sexp_define_foreign(ctx, env, "random-real", 0, sexp_random_real); + if (sexp_opcodep(op)) + sexp_opcode_arg1_type(op) = sexp_make_fixnum(rs_type_id); + op = sexp_define_foreign(ctx, env, "random-source-state-ref", 1, sexp_random_source_state_ref); + if (sexp_opcodep(op)) + sexp_opcode_arg1_type(op) = sexp_make_fixnum(rs_type_id); + op = sexp_define_foreign(ctx, env, "random-source-state-set!", 2, sexp_random_source_state_set); + if (sexp_opcodep(op)) + sexp_opcode_arg1_type(op) = sexp_make_fixnum(rs_type_id); + op = sexp_define_foreign(ctx, env, "random-source-randomize!", 1, sexp_random_source_randomize); + if (sexp_opcodep(op)) + sexp_opcode_arg1_type(op) = sexp_make_fixnum(rs_type_id); + op = sexp_define_foreign(ctx, env, "random-source-pseudo-randomize!", 3, sexp_random_source_pseudo_randomize); + if (sexp_opcodep(op)) + sexp_opcode_arg1_type(op) = sexp_make_fixnum(rs_type_id); - default_random_source = op = sexp_make_random_source(ctx, NULL, 0); + sexp_global(ctx, SEXP_G_RANDOM_SOURCE) = op = sexp_make_random_source(ctx, make_op, 0); name = sexp_intern(ctx, "default-random-source", -1); - sexp_env_define(ctx, env, name, default_random_source); - sexp_random_source_randomize(ctx, NULL, 0, default_random_source); + sexp_env_define(ctx, env, name, op); + sexp_random_source_randomize(ctx, NULL, 0, op); - sexp_gc_release2(ctx); + sexp_gc_release3(ctx); return SEXP_VOID; } -