From c6b0c2319c20a20077f3ce41cf66427a74c04819 Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Wed, 16 Dec 2009 17:43:56 +0900
Subject: [PATCH] adding srfi-27

---
 Makefile                     |   6 +-
 include/chibi/sexp.h         |   4 +
 lib/srfi/27.module           |  11 +++
 lib/srfi/27/constructors.scm |   7 ++
 lib/srfi/27/rand.c           | 153 +++++++++++++++++++++++++++++++++++
 sexp.c                       |   6 +-
 6 files changed, 181 insertions(+), 6 deletions(-)
 create mode 100644 lib/srfi/27.module
 create mode 100644 lib/srfi/27/constructors.scm
 create mode 100644 lib/srfi/27/rand.c

diff --git a/Makefile b/Makefile
index 925b1eb7..0a892b6f 100644
--- a/Makefile
+++ b/Makefile
@@ -53,8 +53,10 @@ endif
 
 all: chibi-scheme$(EXE) libs
 
-COMPILED_LIBS := lib/srfi/33/bit$(SO) lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \
-	lib/chibi/ast$(SO) lib/chibi/net$(SO) lib/chibi/posix$(SO) # lib/chibi/heap-stats$(SO)
+COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \
+	lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \
+	lib/chibi/ast$(SO) lib/chibi/net$(SO) \
+	lib/chibi/posix$(SO) # lib/chibi/heap-stats$(SO)
 
 libs: $(COMPILED_LIBS)
 
diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h
index 1b487a54..b4527037 100644
--- a/include/chibi/sexp.h
+++ b/include/chibi/sexp.h
@@ -352,6 +352,10 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
 
 #define sexp_offsetof(type, f) (offsetof(struct sexp_struct, value.type.f))
 
+#define sexp_offsetof_slot0 (offsetof(struct sexp_struct, value))
+
+#define sexp_sizeof_header (sexp_sizeof(flonum) - sizeof(double))
+
 #define sexp_alloc_type(ctx, type, tag) sexp_alloc_tagged(ctx, sexp_sizeof(type), tag)
 
 #if USE_BIGNUMS
diff --git a/lib/srfi/27.module b/lib/srfi/27.module
new file mode 100644
index 00000000..198d444e
--- /dev/null
+++ b/lib/srfi/27.module
@@ -0,0 +1,11 @@
+
+(define-module (srfi 27)
+  (export random-integer random-real default-random-source
+          make-random-source random-source?
+          random-source-state-ref random-source-state-set!
+          random-source-randomize! random-source-pseudo-randomize!
+          random-source-make-integers random-source-make-reals)
+  (import (scheme))
+  (include-shared "27/rand")
+  (include "27/constructors.scm"))
+
diff --git a/lib/srfi/27/constructors.scm b/lib/srfi/27/constructors.scm
new file mode 100644
index 00000000..473ad2a2
--- /dev/null
+++ b/lib/srfi/27/constructors.scm
@@ -0,0 +1,7 @@
+
+(define (random-source-make-integers rs)
+  (lambda (n) (%random-integer rs n)))
+
+(define (random-source-make-reals rs . o)
+  (lambda () (%random-real rs)))
+
diff --git a/lib/srfi/27/rand.c b/lib/srfi/27/rand.c
new file mode 100644
index 00000000..4ae30f50
--- /dev/null
+++ b/lib/srfi/27/rand.c
@@ -0,0 +1,153 @@
+
+#include <time.h>
+#include <chibi/eval.h>
+
+#define SEXP_RANDOM_STATE_SIZE 128
+
+#define ZERO sexp_make_fixnum(0)
+#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_state(x) (sexp_slot_ref((x), 0))
+#define sexp_random_data(x) ((struct random_data*)(&sexp_slot_ref((x), 1)))
+
+#define sexp_random_init(x, seed)                                       \
+  initstate_r(seed,                                                     \
+              sexp_string_data(sexp_random_state(x)),                   \
+              SEXP_RANDOM_STATE_SIZE,                                   \
+              sexp_random_data(x))
+
+#define sexp_sizeof_random (sexp_sizeof_header + sizeof(struct random_data) + sizeof(sexp))
+
+static sexp_uint_t rs_type_id;
+static sexp default_random_source;
+
+static sexp sexp_rs_random_integer (sexp ctx, sexp rs, sexp bound) {
+  sexp res;
+  int32_t n, hi, mod, len, i, *data;
+  if (! sexp_random_source_p(rs))
+    res = sexp_type_exception(ctx, "not a random-source", rs);
+  if (sexp_fixnump(bound)) {
+    random_r(sexp_random_data(rs), &n);
+    res = sexp_make_fixnum(n % sexp_unbox_fixnum(bound));
+#if USE_BIGNUMS
+  } else if (sexp_bignump(bound)) {
+    hi = sexp_bignum_hi(bound);
+    len = hi * sizeof(sexp_uint_t) / sizeof(int32_t);
+    res = sexp_make_bignum(ctx, hi);
+    data = (int32_t*) sexp_bignum_data(res);
+    for (i=0; i<len-1; i++) {
+      random_r(sexp_random_data(rs), &n);
+      data[i] = n;
+    }
+    random_r(sexp_random_data(rs), &n);
+    mod = sexp_bignum_data(bound)[hi-1] * sizeof(int32_t) / sizeof(sexp_uint_t);
+    if (mod)
+      data[i] = n % mod;
+#endif
+  } else {
+    res = sexp_type_exception(ctx, "random-integer: not an integer", bound);
+  }
+  return res;
+}
+
+static sexp sexp_random_integer (sexp ctx, sexp bound) {
+  return sexp_rs_random_integer(ctx, default_random_source, bound);
+}
+
+static sexp sexp_rs_random_real (sexp ctx, sexp rs) {
+  int32_t res;
+  if (! sexp_random_source_p(rs))
+    return sexp_type_exception(ctx, "not a random-source", rs);
+  random_r(sexp_random_data(rs), &res);
+  return sexp_make_flonum(ctx, (double)res / (double)RAND_MAX);
+}
+
+static sexp sexp_random_real (sexp ctx) {
+  return sexp_rs_random_real(ctx, default_random_source);
+}
+
+static sexp sexp_make_random_source (sexp ctx) {
+  sexp res;
+  sexp_gc_var1(state);
+  sexp_gc_preserve1(ctx, state);
+  state = sexp_make_string(ctx, STATE_SIZE, SEXP_UNDEF);
+  res = sexp_alloc_tagged(ctx, sexp_sizeof_random, rs_type_id);
+  sexp_random_state(res) = state;
+  sexp_random_init(res, 1);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+static sexp sexp_random_source_state_ref (sexp ctx, sexp rs) {
+  if (! sexp_random_source_p(rs))
+    return sexp_type_exception(ctx, "not a random-source", rs);
+  else
+    return sexp_substring(ctx, sexp_random_state(rs), ZERO, STATE_SIZE);
+}
+
+static sexp sexp_random_source_state_set (sexp ctx, sexp rs, sexp state) {
+  if (! sexp_random_source_p(rs))
+    return sexp_type_exception(ctx, "not a random-source", rs);
+  else if (! (sexp_stringp(state)
+              && (sexp_string_length(state) == SEXP_RANDOM_STATE_SIZE)))
+    return sexp_type_exception(ctx, "not a valid random-state", state);
+  sexp_random_state(rs) = state;
+  sexp_random_init(rs, 1);
+  return SEXP_VOID;
+}
+
+static sexp sexp_random_source_randomize (sexp ctx, sexp rs) {
+  if (! sexp_random_source_p(rs))
+    return sexp_type_exception(ctx, "not a random-source", rs);
+  srandom_r(time(NULL), sexp_random_data(rs));
+  return SEXP_VOID;
+}
+
+static sexp sexp_random_source_pseudo_randomize (sexp ctx, sexp rs, sexp seed) {
+  if (! sexp_random_source_p(rs))
+    return sexp_type_exception(ctx, "not a random-source", rs);
+  if (! sexp_fixnump(seed))
+    return sexp_type_exception(ctx, "not an integer", seed);
+  srandom_r(sexp_unbox_fixnum(seed), sexp_random_data(rs));
+  return SEXP_VOID;
+}
+
+sexp sexp_init_library (sexp ctx, sexp env) {
+  sexp_gc_var2(name, op);
+  sexp_gc_preserve2(ctx, name, op);
+
+  name = sexp_c_string(ctx, "random-source", -1);
+  rs_type_id
+    = sexp_unbox_fixnum(sexp_register_type(ctx, name,
+                                           sexp_make_fixnum(sexp_offsetof_slot0),
+                                           ONE, ONE, ZERO, ZERO,
+                                           sexp_make_fixnum(sexp_sizeof_random),
+                                           ZERO, ZERO, NULL));
+
+  name = sexp_c_string(ctx, "random-source?", -1);
+  op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(rs_type_id));
+  name = sexp_intern(ctx, "random-source?");
+  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!", 2, sexp_random_source_pseudo_randomize);
+
+  default_random_source = op = sexp_make_random_source(ctx);
+  name = sexp_intern(ctx, "default-random-source");
+  sexp_env_define(ctx, env, name, default_random_source);
+  sexp_random_source_randomize(ctx, default_random_source);
+
+  sexp_gc_release2(ctx);
+  return SEXP_VOID;
+}
+
diff --git a/sexp.c b/sexp.c
index 4a860fc5..2432c264 100644
--- a/sexp.c
+++ b/sexp.c
@@ -151,11 +151,9 @@ sexp sexp_register_type (sexp ctx, sexp name, sexp fb, sexp felb, sexp flb,
 }
 
 sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots) {
-  short type_size
-    = sexp_sizeof(flonum) - sizeof(double) + sizeof(sexp)*sexp_unbox_fixnum(slots);
+  short type_size = sexp_sizeof_header + sizeof(sexp)*sexp_unbox_fixnum(slots);
   return
-    sexp_register_type(ctx, name,
-                       sexp_make_fixnum(offsetof(struct sexp_struct, value)),
+    sexp_register_type(ctx, name, sexp_make_fixnum(sexp_offsetof_slot0),
                        slots, slots, sexp_make_fixnum(0), sexp_make_fixnum(0),
                        sexp_make_fixnum(type_size), sexp_make_fixnum(0),
                        sexp_make_fixnum(0), NULL);