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

adding lazy

Browse source
This commit is contained in:
Alex Shinn 2011-10-05 21:21:27 +09:00
parent 0bc1e27224
commit 7459df91b6
4 changed files with 32 additions and 21 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
eval.c
View file

@ -1490,12 +1490,10 @@ sexp sexp_string_utf8_index_set (sexp ctx sexp_api_params(self, n), sexp str, se
#endif
#if SEXP_USE_AUTO_FORCE
sexp sexp_make_promise (sexp ctx sexp_api_params(self, n), sexp thunk) {
sexp_assert_type(ctx, sexp_applicablep, SEXP_PROCEDURE, thunk);
sexp sexp_make_promise (sexp ctx sexp_api_params(self, n), sexp done, sexp val) {
sexp res = sexp_alloc_type(ctx, promise, SEXP_PROMISE);
sexp_promise_donep(res) = 0;
sexp_promise_thunk(res) = thunk;
sexp_promise_value(res) = SEXP_VOID;
sexp_promise_donep(res) = sexp_unbox_boolean(done);
sexp_promise_value(res) = val;
return res;
}
#endif

33
lib/init-7.scm
View file

@ -308,10 +308,15 @@
,(map (lambda (x) (list (car x) (cadr x))) (cadr expr))
,wrap)))))
(define-syntax lazy
(er-macro-transformer
(lambda (expr rename compare)
`(,(rename 'make-promise) #f (,(rename 'lambda) () ,(cadr expr))))))
(define-syntax delay
(er-macro-transformer
(lambda (expr rename compare)
`(,(rename 'make-promise) (,(rename 'lambda) () ,(cadr expr))))))
`(,(rename 'lazy) (,(rename 'make-promise) #t ,(cadr expr))))))
(define-syntax define-auxiliary-syntax
(er-macro-transformer
@ -896,17 +901,23 @@
(cond-expand
(auto-force
(define (force x) x))
)
(else
(define (make-promise thunk)
(lambda ()
(let ((computed? #f) (result #f))
(if (not computed?)
(begin
(set! result (thunk))
(set! computed? #t)))
result)))
(define (force x) (if (procedure? x) (x) x))))
(define (make-promise done? proc)
(list (cons done? proc)))
(define (promise-done? x) (car (car x)))
(define (promise-value x) (cdr (car x)))
(define (promise-update! new old)
(set-car! (car old) (promise-done? new))
(set-cdr! (car old) (promise-value new))
(set-car! new (car old)))
(define (force promise)
(if (promise-done? promise)
(promise-value promise)
(let ((promise* ((promise-value promise))))
(if (not (promise-done? promise))
(promise-update! promise* promise))
(force promise))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; math utils

3
opcodes.c
View file

@ -223,7 +223,8 @@ _FN0(SEXP_VOID, "reset-vm-profile", 0, sexp_reset_vm_profile),
_FN0(SEXP_VOID, "print-vm-profile", 0, sexp_print_vm_profile),
#endif
#if SEXP_USE_AUTO_FORCE
_FN1(_I(SEXP_PROMISE), _I(SEXP_PROCEDURE), "make-promise", 0, sexp_make_promise),
_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), "make-promise", 0, sexp_make_promise),
#endif
};

9
vm.c
View file

@ -1780,10 +1780,11 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
_ARG1 = sexp_promise_value(_ARG1);
} else {
sexp_context_top(ctx) = top;
tmp1 = sexp_apply(ctx, sexp_promise_thunk(_ARG1), SEXP_NULL);
sexp_promise_value(_ARG1) = tmp1;
sexp_promise_donep(_ARG1) = 1;
sexp_promise_thunk(_ARG1) = SEXP_FALSE;
tmp1 = sexp_apply(ctx, sexp_promise_value(_ARG1), SEXP_NULL);
if (!sexp_promise_donep(_ARG1)) {
sexp_promise_value(_ARG1) = tmp1;
sexp_promise_donep(_ARG1) = 1;
}
_ARG1 = tmp1;
}
}