diff --git a/Makefile b/Makefile index d19d5b86..ee7909d4 100644 --- a/Makefile +++ b/Makefile @@ -103,8 +103,8 @@ endif all: chibi-scheme$(EXE) libs -COMPILED_LIBS := lib/srfi/18/threads$(SO) lib/srfi/27/rand$(SO) \ - lib/srfi/33/bit$(SO) lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) \ +COMPILED_LIBS := lib/srfi/18/threads$(SO) lib/srfi/27/rand$(SO) lib/srfi/33/bit$(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) \ diff --git a/lib/srfi/39.module b/lib/srfi/39.module index e77a3c50..367e9cf5 100644 --- a/lib/srfi/39.module +++ b/lib/srfi/39.module @@ -19,24 +19,5 @@ (define-module (srfi 39) (export make-parameter parameterize) (import-immutable (scheme)) - (body - (define (make-parameter value . o) - (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)))))) + (include-shared "39/param") + (include "39/syntax.scm")) diff --git a/lib/srfi/39/param.c b/lib/srfi/39/param.c new file mode 100644 index 00000000..8e05b726 --- /dev/null +++ b/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 + +#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; +} + diff --git a/lib/srfi/39/syntax.scm b/lib/srfi/39/syntax.scm new file mode 100644 index 00000000..72e04674 --- /dev/null +++ b/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))))