* Makefile (OBJS): new object file, rand.o.

* eval.c: Includes rand.h header.
(eval_init): New variable and functions from rand module registered.

* lib.c: Includes rand.h header.
(init): Call rand_init.

* rand.c: New file.

* rand.h: New file.

6 files changed, 256 insertions, 1 deletions

diff --git a/ChangeLog b/ChangeLog
index cba89b14..82adbaf2 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,19 @@
 2011-12-21  Kaz Kylheku  <kaz@kylheku.com>
 
+	* Makefile (OBJS): new object file, rand.o.
+
+	* eval.c: Includes rand.h header.
+	(eval_init): New variable and functions from rand module registered.
+
+	* lib.c: Includes rand.h header.
+	(init): Call rand_init.
+
+	* rand.c: New file.
+
+	* rand.h: New file.
+
+2011-12-21  Kaz Kylheku  <kaz@kylheku.com>
+
 	Bug #35139
 
 	Better fix.
diff --git a/Makefile b/Makefile
index c5aaaa66..31636008 100644
--- a/Makefile
+++ b/Makefile
@@ -39,7 +39,7 @@ endif
 
 # TXR objects
 OBJS := txr.o lex.yy.o y.tab.o match.o lib.o regex.o gc.o unwind.o stream.o
-OBJS += arith.o hash.o utf8.o filter.o debug.o eval.o
+OBJS += arith.o hash.o utf8.o filter.o debug.o eval.o rand.o
 
 # MPI objects
 MPI_OBJ_BASE=mpi.o mplogic.o
diff --git a/eval.c b/eval.c
index 8f8ed0aa..1a77deb1 100644
--- a/eval.c
+++ b/eval.c
@@ -42,6 +42,7 @@
 #include "hash.h"
 #include "debug.h"
 #include "match.h"
+#include "rand.h"
 #include "eval.h"
 
 typedef val (*opfun_t)(val, val);
@@ -1411,6 +1412,12 @@ void eval_init(void)
   reg_fun(intern(lit("functionp"), user_package), func_n1(functionp));
   reg_fun(intern(lit("interp-fun-p"), user_package), func_n1(interp_fun_p));
 
+  reg_var(intern(lit("*random-state*"), user_package), random_state);
+  reg_fun(intern(lit("make-random-state"), user_package), func_n1(make_random_state));
+  reg_fun(intern(lit("random-state-p"), user_package), func_n1(random_state_p));
+  reg_fun(intern(lit("random-fixnum"), user_package), func_n1(random_fixnum));
+  reg_fun(intern(lit("random"), user_package), func_n2(random));
+
   eval_error_s = intern(lit("eval-error"), user_package);
   uw_register_subtype(eval_error_s, error_s);
 }
diff --git a/lib.c b/lib.c
index 3cf9113d..eb4d2ef3 100644
--- a/lib.c
+++ b/lib.c
@@ -43,6 +43,7 @@
 #include "lib.h"
 #include "gc.h"
 #include "arith.h"
+#include "rand.h"
 #include "hash.h"
 #include "unwind.h"
 #include "stream.h"
@@ -3447,6 +3448,7 @@ void init(const wchar_t *pn, mem_t *(*oom)(mem_t *, size_t),
   gc_init(stack_bottom);
   obj_init();
   arith_init();
+  rand_init();
   uw_init();
   stream_init();
   eval_init();
diff --git a/rand.c b/rand.c
new file mode 100644
index 00000000..47b882a4
--- /dev/null
+++ b/rand.c
@@ -0,0 +1,199 @@
+/* Copyright 2012
+ * Kaz Kylheku <kaz@kylheku.com>
+ * Vancouver, Canada
+ * All rights reserved.
+ *
+ * BSD License:
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ *
+ *   1. Redistributions of source code must retain the above copyright
+ *      notice, this list of conditions and the following disclaimer.
+ *   2. Redistributions in binary form must reproduce the above copyright
+ *      notice, this list of conditions and the following disclaimer in
+ *      the documentation and/or other materials provided with the
+ *      distribution.
+ *   3. The name of the author may not be used to endorse or promote
+ *      products derived from this software without specific prior
+ *      written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
+ * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
+ * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+ */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <wctype.h>
+#include <assert.h>
+#include <limits.h>
+#include <stdarg.h>
+#include <dirent.h>
+#include <setjmp.h>
+#include <wchar.h>
+#include <limits.h>
+#include <time.h>
+#include "config.h"
+#include "lib.h"
+#include "unwind.h"
+#include "gc.h"
+#include "arith.h"
+#include "rand.h"
+
+#if SIZEOF_INT == 4
+typedef unsigned int rand32_t;
+#elif SIZEOF_LONG == 4
+typedef unsigned long rand32_t;
+#endif
+
+struct random_state {
+  rand32_t state[16];
+  int cur;
+};
+
+val random_state;
+val random_state_s;
+
+static struct cobj_ops random_state_ops = {
+  cobj_equal_op,
+  cobj_print_op,
+  cobj_destroy_free_op,
+  cobj_mark_op,
+  cobj_hash_op 
+};
+
+static val make_state()
+{
+  struct random_state *r = (struct random_state *) chk_malloc(sizeof *r);
+  return cobj((mem_t *) r, random_state_s, &random_state_ops);
+}
+
+val random_state_p(val obj)
+{
+  return typeof(obj) == random_state_s ? t : nil;
+}
+
+val make_random_state(val seed)
+{
+  val rs = make_state();
+  struct random_state *r = (struct random_state *) 
+                             cobj_handle(rs, random_state_s);
+
+  r->cur = 0;
+
+  if (bignump(seed)) {
+    int i, dig, bit;
+    mp_int *m = mp(seed);
+
+    for (i = 0, dig = 0, bit = 0; i < 16 && dig < m->used; i++) {
+      r->state[i] = (m->dp[dig] >> bit) & 0xFFFFFFFFul;
+      bit += 32;
+      if (bit >= MP_DIGIT_BIT)
+        dig++, bit = 0;
+    }
+
+    for (; i < 16; i++) {
+      r->state[i] = 0xAAAAAAAA;
+    }
+  } else if (fixnump(seed)) {
+    cnum s = c_num(seed) & NUM_MAX;
+
+    memset(r->state, 0xAA, sizeof r->state);
+    r->state[0] = s & 0xFFFFFFFFul;
+#if SIZEOF_PTR >= 8
+    r->state[1] = (s >> 32) & 0xFFFFFFFFul;
+#elif SIZEOF_PTR >= 16
+    r->state[2] = (s >> 64) & 0xFFFFFFFFul;
+    r->state[3] = (s >> 96) & 0xFFFFFFFFul;
+#endif
+  } else if (nullp(seed)) {
+    r->state[0] = (rand32_t) time(0);
+    r->state[1] = (rand32_t) clock();
+    memset(r->state + 2, 0xAA, sizeof r->state - 2 * sizeof r->state[0]);
+  } else if (random_state_p(seed)) {
+    struct random_state *rseed = (struct random_state *) 
+                                   cobj_handle(seed, random_state_s);
+    *r = *rseed;
+  } else {
+    uw_throwf(error_s, lit("make-random-state: seed ~s is not a number"),
+              seed, nao);
+  }
+
+  return rs;
+}
+
+static rand32_t rand32(struct random_state *r)
+{
+  #define RSTATE(r,i) ((r)->state[((r)->cur + i) % 16])
+  rand32_t s0 = RSTATE(r, 0);
+  rand32_t s9 = RSTATE(r, 9);
+  rand32_t s13 = RSTATE(r, 13);
+  rand32_t s15 = RSTATE(r, 15);
+
+  rand32_t r1 = s0 ^ (s0 << 16) ^ s13 ^ (s13 << 15);
+  rand32_t r2 = s9 ^ (s9 >> 11);
+
+  rand32_t ns0 = RSTATE(r, 0) = r1 ^ r2;
+  rand32_t ns15 = s15 ^ (s15 << 2) ^ r1 ^ (r1 << 18) ^ r2 ^ (r2 << 28) ^ 
+                  ((ns0 ^ (ns0 << 5)) & 0xda442d24ul);
+
+  RSTATE(r, 15) = ns15;
+  r->cur = (r->cur + 15) % 16;
+  return ns15;
+  #undef RSTATE
+}
+
+val random_fixnum(val state)
+{
+  uses_or2;
+  struct random_state *r = (struct random_state *) 
+                             cobj_handle(or2(state, random_state),
+                                         random_state_s);
+  return num(rand32(r) & NUM_MAX);
+}
+
+val random(val state, val modulus)
+{
+  uses_or2;
+  struct random_state *r = (struct random_state *) 
+                             cobj_handle(or2(state, random_state),
+                                         random_state_s);
+  if (bignump(modulus)) {
+    mp_int *m = mp(modulus);
+    int digits = USED(m);
+    int bits = digits * MP_DIGIT_BIT;
+    int bits_needed = bits + 32;
+    int digits_needed = (bits_needed + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT;
+    val out = make_bignum();
+    mp_int *om = mp(out);
+    int i, err;
+
+    for (i = 0; i < digits_needed; i++) {
+      if (i > 0)
+        mp_mul_2d(om, 32, om);
+      mp_add_d(om, rand32(r), om);
+    }
+    err = mp_mod(om, m, om);
+    if (err != MP_OKAY)
+      goto invalid;
+    return out;
+  } else if (fixnump(modulus)) {
+    cnum m = c_num(modulus);
+    if (m <= 0)
+      goto invalid;
+    return num(rand32(r) % m);
+  } 
+invalid:
+  uw_throwf(numeric_error_s, lit("random: invalid modulus ~s"),
+      modulus, nao);
+}
+
+void rand_init(void)
+{
+  prot1(&random_state);
+  random_state_s = intern(lit("random-state"), user_package);
+  random_state = make_random_state(num(42));
+}
diff --git a/rand.h b/rand.h
new file mode 100644
index 00000000..7426b461
--- /dev/null
+++ b/rand.h
@@ -0,0 +1,33 @@
+/* Copyright 2012
+ * Kaz Kylheku <kaz@kylheku.com>
+ * Vancouver, Canada
+ * All rights reserved.
+ *
+ * BSD License:
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ *
+ *   1. Redistributions of source code must retain the above copyright
+ *      notice, this list of conditions and the following disclaimer.
+ *   2. Redistributions in binary form must reproduce the above copyright
+ *      notice, this list of conditions and the following disclaimer in
+ *      the documentation and/or other materials provided with the
+ *      distribution.
+ *   3. The name of the author may not be used to endorse or promote
+ *      products derived from this software without specific prior
+ *      written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
+ * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
+ * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+ */
+
+extern val random_state;
+extern val random_state_s;
+val make_random_state(val seed);
+val random_state_p(val obj);
+val random_fixnum(val state);
+val random(val state, val modulus);
+void rand_init(void);