parameters are now thread-local

Makefile

@@ -103,8 +103,8 @@ endif
 
 all: chibi-scheme$(EXE) libs
 
-COMPILED_LIBS := lib/srfi/18/threads$(SO) lib/srfi/27/rand$(SO) \
+COMPILED_LIBS := lib/srfi/18/threads$(SO) lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \
-	lib/srfi/33/bit$(SO) lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) \
+	lib/srfi/39/param$(SO) lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) \
 	lib/srfi/98/env$(SO) lib/chibi/ast$(SO) lib/chibi/net$(SO) \
 	lib/chibi/filesystem$(SO) lib/chibi/process$(SO) lib/chibi/time$(SO) \
 	lib/chibi/system$(SO) lib/chibi/io/io$(SO) lib/chibi/stty$(SO) \

lib/srfi/39.module

@@ -19,24 +19,5 @@
 (define-module (srfi 39)
   (export make-parameter parameterize)
   (import-immutable (scheme))
-  (body
+  (include-shared "39/param")
-   (define (make-parameter value . o)
+  (include "39/syntax.scm"))
-     (if (pair? o)
-         (let ((converter (car o)))
-           (lambda args
-             (if (null? args)
-                 value
-                 (set! value (converter (car args))))))
-         (lambda args (if (null? args) value (set! value (car args))))))
-   (define-syntax parameterize
-     (syntax-rules ()
-       ((parameterize ("step") ((param value tmp1 tmp2) ...) () body)
-        (let ((tmp1 value) ...)
-          (let ((tmp2 (param)) ...)
-            (dynamic-wind (lambda () (param tmp1) ...)
-                          (lambda () . body)
-                          (lambda () (param tmp2) ...)))))
-       ((parameterize ("step") args ((param value) . rest) body)
-        (parameterize ("step") ((param value tmp1 tmp2) . args) rest body))
-       ((parameterize ((param value) ...) . body)
-        (parameterize ("step") () ((param value) ...) body))))))

lib/srfi/39/param.c

@@ -0,0 +1,48 @@
+/*  param.c -- low-level parameter utilities                  */
+/*  Copyright (c) 2010 Alex Shinn.  All rights reserved.      */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include <chibi/eval.h>
+
+#define _I(x) sexp_make_fixnum(x)
+
+static sexp sexp_make_parameter (sexp ctx sexp_api_params(self, n), sexp init, sexp conv) {
+  sexp res;
+  sexp_gc_var1(cell);
+  sexp_gc_preserve1(ctx, cell);
+  cell = sexp_cons(ctx, SEXP_FALSE, init);
+  res = sexp_make_opcode(ctx, self, SEXP_FALSE, _I(SEXP_OPC_PARAMETER),
+                         _I(SEXP_OP_PARAMETER_REF), SEXP_ZERO, SEXP_ONE,
+                         _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_ZERO,
+                         cell, conv, NULL);
+  sexp_gc_release1(ctx);
+  return res;
+}
+
+static sexp sexp_parameter_converter (sexp ctx sexp_api_params(self, n), sexp param) {
+  sexp res;
+  sexp_assert_type(ctx, sexp_opcodep, SEXP_OPCODE, param);
+  res = sexp_opcode_data2(param);
+  return res ? res : SEXP_FALSE;
+}
+
+static sexp sexp_thread_parameters (sexp ctx sexp_api_params(self, n)) {
+  sexp res = sexp_context_params(ctx);
+  return res ? res : SEXP_NULL;
+}
+
+static sexp sexp_thread_parameters_set (sexp ctx sexp_api_params(self, n), sexp new) {
+  sexp_context_params(ctx) = new;
+  return SEXP_VOID;
+}
+
+sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {
+
+  sexp_define_foreign(ctx, env, "%make-parameter", 2, sexp_make_parameter);
+  sexp_define_foreign(ctx, env, "parameter-converter", 1, sexp_parameter_converter);
+  sexp_define_foreign(ctx, env, "thread-parameters", 0, sexp_thread_parameters);
+  sexp_define_foreign(ctx, env, "thread-parameters-set!", 1, sexp_thread_parameters_set);
+
+  return SEXP_VOID;
+}
+

lib/srfi/39/syntax.scm

@@ -0,0 +1,29 @@
+;; param.scm -- SRFI-39 parameters
+;; Copyright (c) 2010 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (parameter-convert param value)
+  (let ((proc (parameter-converter param)))
+    (if (procedure? proc)
+        (proc value)
+        value)))
+
+(define (make-parameter init . o)
+  (let ((conv (and (pair? o) (car o))))
+    (%make-parameter (if conv (conv init) init) conv)))
+
+(define-syntax parameterize
+  (syntax-rules ()
+    ((parameterize ("step") old cons-new ((param value ptmp vtmp) ...) () body)
+     (let ((ptmp param) ...)
+       (let ((vtmp (parameter-convert ptmp value)) ...)
+         (let ((old (thread-parameters)))
+           (let ((new cons-new))
+             (dynamic-wind
+                 (lambda () (thread-parameters-set! new))
+                 (lambda () . body)
+                 (lambda () (thread-parameters-set! old))))))))
+    ((parameterize ("step") old cons-new args ((param value) . rest) body)
+     (parameterize ("step") old (cons (cons ptmp vtmp) cons-new) ((param value ptmp vtmp) . args) rest body))
+    ((parameterize ((param value) ...) . body)
+     (parameterize ("step") old (thread-parameters) () ((param value) ...) body))))