Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-22 07:09:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Use a context global instead of a static C global for the default random source.

Browse source 
Fixes issue #385.
This commit is contained in:
Alex Shinn 2017-01-20 00:49:11 +09:00
parent 29328bfc9d
commit 260f55adec
2 changed files with 59 additions and 43 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
include/chibi/sexp.h
View file

@ -1345,6 +1345,7 @@ enum sexp_context_globals {
SEXP_G_ERR_HANDLER, SEXP_G_ERR_HANDLER,
SEXP_G_RESUMECC_BYTECODE, SEXP_G_RESUMECC_BYTECODE,
SEXP_G_FINAL_RESUMER, SEXP_G_FINAL_RESUMER,
SEXP_G_RANDOM_SOURCE,
SEXP_G_STRICT_P, SEXP_G_STRICT_P,
SEXP_G_NO_TAIL_CALLS_P, SEXP_G_NO_TAIL_CALLS_P,
#if SEXP_USE_FOLD_CASE_SYMS #if SEXP_USE_FOLD_CASE_SYMS

101
lib/srfi/27/rand.c
View file

@ -1,5 +1,5 @@
/* rand.c -- rand_r/random_r interface */ /* 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 */ /* BSD-style license: http://synthcode.com/license.txt */
#include <time.h> #include <time.h>
@ -11,16 +11,13 @@
#define ONE sexp_make_fixnum(1) #define ONE sexp_make_fixnum(1)
#define STATE_SIZE sexp_make_fixnum(SEXP_RANDOM_STATE_SIZE) #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_state(x) (sexp_slot_ref((x), 0))
#define sexp_random_data(x) ((sexp_random_t*)(&sexp_slot_ref((x), 1))) #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)) #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__ #ifdef __GNU_LIBRARY__
typedef struct random_data sexp_random_t; 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_uint32_t *data;
sexp_int32_t hi, len, i; sexp_int32_t hi, len, i;
#endif #endif
if (! sexp_random_source_p(rs)) if (!sexp_random_source_p(self, rs))
res = sexp_type_exception(ctx, self, rs_type_id, rs); return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), rs);
if (sexp_fixnump(bound)) { if (sexp_fixnump(bound)) {
sexp_call_random(rs, m); sexp_call_random(rs, m);
res = sexp_make_fixnum(m % sexp_unbox_fixnum(bound)); 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) { 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 sexp_rs_random_real (sexp ctx, sexp self, sexp_sint_t n, sexp rs) {
sexp_int32_t res; sexp_int32_t res;
if (! sexp_random_source_p(rs)) if (!sexp_random_source_p(self, rs))
return sexp_type_exception(ctx, self, rs_type_id, rs); return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), rs);
sexp_call_random(rs, res); sexp_call_random(rs, res);
return sexp_make_flonum(ctx, (double)res / (double)RAND_MAX); return sexp_make_flonum(ctx, (double)res / (double)RAND_MAX);
} }
sexp sexp_random_real (sexp ctx, sexp self, sexp_sint_t n) { 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__) #if SEXP_BSD || defined(__CYGWIN__)
sexp sexp_make_random_source (sexp ctx, sexp self, sexp_sint_t n) { sexp sexp_make_random_source (sexp ctx, sexp self, sexp_sint_t n) {
sexp res; 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; *sexp_random_data(res) = 1;
return res; return res;
} }
sexp sexp_random_source_state_ref (sexp ctx, sexp self, sexp_sint_t n, sexp rs) { sexp sexp_random_source_state_ref (sexp ctx, sexp self, sexp_sint_t n, sexp rs) {
if (! sexp_random_source_p(rs)) if (!sexp_random_source_p(self, rs))
return sexp_type_exception(ctx, self, rs_type_id, rs); return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), rs);
else else
return sexp_make_integer(ctx, *sexp_random_data(rs)); 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) { sexp sexp_random_source_state_set (sexp ctx, sexp self, sexp_sint_t n, sexp rs, sexp state) {
if (! sexp_random_source_p(rs)) if (!sexp_random_source_p(self, rs))
return sexp_type_exception(ctx, self, rs_type_id, rs); return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), rs);
else if (sexp_fixnump(state)) else if (sexp_fixnump(state))
*sexp_random_data(rs) = sexp_unbox_fixnum(state); *sexp_random_data(rs) = sexp_unbox_fixnum(state);
#if SEXP_USE_BIGNUMS #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_var1(state);
sexp_gc_preserve1(ctx, state); sexp_gc_preserve1(ctx, state);
state = sexp_make_bytes(ctx, STATE_SIZE, SEXP_UNDEF); 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; if (sexp_exceptionp(res)) return res;
sexp_random_state(res) = state; sexp_random_state(res) = state;
sexp_random_init(res, 1); 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) { sexp sexp_random_source_state_ref (sexp ctx, sexp self, sexp_sint_t n, sexp rs) {
if (! sexp_random_source_p(rs)) if (self && ! (sexp_pointerp(rs) && (sexp_pointer_tag(rs) == sexp_unbox_fixnum(sexp_opcode_arg1_type(self)))))
return sexp_type_exception(ctx, self, rs_type_id, rs); return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), rs);
else else
return sexp_subbytes(ctx, sexp_random_state(rs), ZERO, STATE_SIZE); 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) { sexp sexp_random_source_state_set (sexp ctx, sexp self, sexp_sint_t n, sexp rs, sexp state) {
if (! sexp_random_source_p(rs)) if (!sexp_random_source_p(self, rs))
return sexp_type_exception(ctx, self, rs_type_id, rs); return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), rs);
else if (! (sexp_bytesp(state) else if (! (sexp_bytesp(state)
&& (sexp_bytes_length(state) == SEXP_RANDOM_STATE_SIZE))) && (sexp_bytes_length(state) == SEXP_RANDOM_STATE_SIZE)))
return sexp_type_exception(ctx, self, SEXP_BYTES, state); 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 #endif
sexp sexp_random_source_randomize (sexp ctx, sexp self, sexp_sint_t n, sexp rs) { sexp sexp_random_source_randomize (sexp ctx, sexp self, sexp_sint_t n, sexp rs) {
if (! sexp_random_source_p(rs)) if (! sexp_random_source_p(self, rs))
return sexp_type_exception(ctx, self, rs_type_id, rs); return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), rs);
sexp_seed_random(time(NULL), rs); sexp_seed_random(time(NULL), rs);
return SEXP_VOID; return SEXP_VOID;
} }
sexp sexp_random_source_pseudo_randomize (sexp ctx, sexp self, sexp_sint_t n, sexp rs, sexp seed1, sexp seed2) { 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)) if (! sexp_random_source_p(self, rs))
return sexp_type_exception(ctx, self, rs_type_id, rs); return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), rs);
if (! sexp_fixnump(seed1)) 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)) 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); sexp_seed_random(sexp_unbox_fixnum(seed1) ^ sexp_unbox_fixnum(seed2), rs);
return SEXP_VOID; 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 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) if (!(sexp_version_compatible(ctx, version, sexp_version)
&& sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER))) && sexp_abi_compatible(ctx, abi, SEXP_ABI_IDENTIFIER)))
return SEXP_ABI_ERROR; 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); name = sexp_c_string(ctx, "random-source", -1);
op = sexp_register_type(ctx, name, SEXP_FALSE, SEXP_FALSE, 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); name = sexp_intern(ctx, "random-source?", -1);
sexp_env_define(ctx, env, name, op); sexp_env_define(ctx, env, name, op);
sexp_define_foreign(ctx, env, "make-random-source", 0, sexp_make_random_source); make_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); if (sexp_opcodep(make_op))
sexp_define_foreign(ctx, env, "random-integer", 1, sexp_random_integer); sexp_opcode_return_type(make_op) = sexp_make_fixnum(rs_type_id);
sexp_define_foreign(ctx, env, "%random-real", 1, sexp_rs_random_real); op = sexp_define_foreign(ctx, env, "%random-integer", 2, sexp_rs_random_integer);
sexp_define_foreign(ctx, env, "random-real", 0, sexp_random_real); if (sexp_opcodep(op))
sexp_define_foreign(ctx, env, "random-source-state-ref", 1, sexp_random_source_state_ref); sexp_opcode_arg1_type(op) = sexp_make_fixnum(rs_type_id);
sexp_define_foreign(ctx, env, "random-source-state-set!", 2, sexp_random_source_state_set); op = sexp_define_foreign(ctx, env, "random-integer", 1, sexp_random_integer);
sexp_define_foreign(ctx, env, "random-source-randomize!", 1, sexp_random_source_randomize); if (sexp_opcodep(op))
sexp_define_foreign(ctx, env, "random-source-pseudo-randomize!", 3, sexp_random_source_pseudo_randomize); 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); name = sexp_intern(ctx, "default-random-source", -1);
sexp_env_define(ctx, env, name, default_random_source); sexp_env_define(ctx, env, name, op);
sexp_random_source_randomize(ctx, NULL, 0, default_random_source); sexp_random_source_randomize(ctx, NULL, 0, op);
sexp_gc_release2(ctx); sexp_gc_release3(ctx);
return SEXP_VOID; return SEXP_VOID;
} }