Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-15 08:57:33 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

Adding missing R7RS promise? and test cases.

Browse source
This commit is contained in:
Alex Shinn 2014-01-30 12:32:19 +09:00
parent 2d685031b0
commit 3c250ef8a7
7 changed files with 37 additions and 7 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
include/chibi/eval.h
View file

@ -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);

3
include/chibi/sexp.h
View file

@ -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))

18
lib/scheme/lazy.sld
View file

@ -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))))))))))

1
opcodes.c
View file

@ -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),
};

2
sexp.c
View file

@ -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
};

11
tests/r7rs-tests.scm
View file

@ -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

6
vm.c
View file

@ -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
}