From 3c250ef8a750eb158884ff657d2eadb85ae95176 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Thu, 30 Jan 2014 12:32:19 +0900 Subject: [PATCH] Adding missing R7RS promise? and test cases. --- include/chibi/eval.h | 3 +++ include/chibi/sexp.h | 3 +-- lib/scheme/lazy.sld | 18 ++++++++++++++++-- opcodes.c | 1 + sexp.c | 2 +- tests/r7rs-tests.scm | 11 +++++++++++ vm.c | 6 ++++-- 7 files changed, 37 insertions(+), 7 deletions(-) diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 6efc7a11..28c37af3 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -127,6 +127,9 @@ SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, SEXP_API sexp sexp_make_procedure_op (sexp ctx, sexp self, sexp_sint_t n, sexp flags, sexp num_args, sexp bc, sexp vars); SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, sexp_proc1 f, sexp data); SEXP_API sexp sexp_register_optimization(sexp ctx, sexp self, sexp_sint_t n, sexp f, sexp i); +#if SEXP_USE_AUTO_FORCE +SEXP_API sexp sexp_make_promise (sexp ctx, sexp self, sexp_sint_t n, sexp done, sexp val); +#endif #if SEXP_USE_UTF8_STRINGS SEXP_API sexp sexp_read_utf8_char (sexp ctx, sexp port, int i); SEXP_API void sexp_string_utf8_set (sexp ctx, sexp str, sexp index, sexp ch); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 79a3e65f..b4f5ad6e 100755 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -435,7 +435,7 @@ struct sexp_struct { #if SEXP_USE_AUTO_FORCE struct { int donep; - sexp thunk, value; + sexp value; } promise; #endif } value; @@ -1024,7 +1024,6 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #define sexp_stack_data(x) (sexp_field(x, stack, SEXP_STACK, data)) #define sexp_promise_donep(x) (sexp_field(x, promise, SEXP_PROMISE, donep)) -#define sexp_promise_thunk(x) (sexp_field(x, promise, SEXP_PROMISE, thunk)) #define sexp_promise_value(x) (sexp_field(x, promise, SEXP_PROMISE, value)) #define sexp_context_env(x) (sexp_field(x, context, SEXP_CONTEXT, env)) diff --git a/lib/scheme/lazy.sld b/lib/scheme/lazy.sld index 02f0117f..b9a06e8b 100644 --- a/lib/scheme/lazy.sld +++ b/lib/scheme/lazy.sld @@ -1,5 +1,19 @@ (define-library (scheme lazy) (import (chibi)) - (export delay force delay-force make-promise) - (begin (define (make-promise x) (delay x)))) + (export delay force delay-force make-promise promise?) + (begin + (define (make-promise x) + (delay x))) + (cond-expand + (auto-force + ) + (else + (begin + (define (promise? x) + (and (pair? x) + (null? (cdr x)) + (pair? (car x)) + (or (eq? #t (caar x)) + (and (eq? #f (caar x)) + (procedure? (cdar x)))))))))) diff --git a/opcodes.c b/opcodes.c index d6a60f3a..01bd182f 100644 --- a/opcodes.c +++ b/opcodes.c @@ -267,6 +267,7 @@ _FN0(SEXP_VOID, "print-vm-profile", 0, sexp_print_vm_profile), #if SEXP_USE_AUTO_FORCE _OP(SEXP_OPC_GENERIC, SEXP_OP_FORCE, 1, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "force", 0, NULL), _FN2(_I(SEXP_PROMISE), _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "promise", 0, sexp_make_promise), +_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "promise?", _I(SEXP_PROMISE), 0), #endif _OP(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0), }; diff --git a/sexp.c b/sexp.c index 2bb67d24..b5dcea02 100644 --- a/sexp.c +++ b/sexp.c @@ -219,7 +219,7 @@ static struct sexp_type_struct _sexp_type_specs[] = { {SEXP_CONTEXT, sexp_offsetof(context, stack), 12+SEXP_USE_DL, 12+SEXP_USE_DL, 0, 0, sexp_sizeof(context), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Context", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL}, {SEXP_CPOINTER, sexp_offsetof(cpointer, parent), 1, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Cpointer", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL}, #if SEXP_USE_AUTO_FORCE - {SEXP_PROMISE, sexp_offsetof(promise, thunk), 2, 2, 0, 0, sexp_sizeof(promise), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Promise", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL}, + {SEXP_PROMISE, sexp_offsetof(promise, value), 1, 1, 0, 0, sexp_sizeof(promise), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Promise", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL}, #endif }; diff --git a/tests/r7rs-tests.scm b/tests/r7rs-tests.scm index 2a3bf916..0816f2e9 100644 --- a/tests/r7rs-tests.scm +++ b/tests/r7rs-tests.scm @@ -307,6 +307,17 @@ (test 6 (force p)) (test 6 (begin (set! x 10) (force p)))) +(test #t (promise? (delay (+ 2 2)))) +(test #t (promise? (make-promise (+ 2 2)))) +(test #t + (let ((x (delay (+ 2 2)))) + (force x) + (promise? x))) +(test #t + (let ((x (make-promise (+ 2 2)))) + (force x) + (promise? x))) + (define radix (make-parameter 10 diff --git a/vm.c b/vm.c index ead92f8c..d573c8b8 100644 --- a/vm.c +++ b/vm.c @@ -332,8 +332,10 @@ static void generate_opcode_app (sexp ctx, sexp app) { for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) { sexp_generate(ctx, 0, 0, 0, sexp_car(ls)); #if SEXP_USE_AUTO_FORCE - if ((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR) - || sexp_opcode_code(op) == SEXP_OP_MAKE_VECTOR) + if (((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR) + || sexp_opcode_code(op) == SEXP_OP_MAKE_VECTOR) + && !(sexp_opcode_class(op) == SEXP_OPC_TYPE_PREDICATE + && sexp_unbox_fixnum(sexp_opcode_data(op)) == SEXP_PROMISE)) sexp_emit(ctx, SEXP_OP_FORCE); #endif }