Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-04 19:56: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 #endif
#if SEXP_USE_AUTO_FORCE #if SEXP_USE_AUTO_FORCE
sexp sexp_make_promise (sexp ctx sexp_api_params(self, n), sexp thunk) { sexp sexp_make_promise (sexp ctx sexp_api_params(self, n), sexp done, sexp val) {
sexp_assert_type(ctx, sexp_applicablep, SEXP_PROCEDURE, thunk);
sexp res = sexp_alloc_type(ctx, promise, SEXP_PROMISE); sexp res = sexp_alloc_type(ctx, promise, SEXP_PROMISE);
sexp_promise_donep(res) = 0; sexp_promise_donep(res) = sexp_unbox_boolean(done);
sexp_promise_thunk(res) = thunk; sexp_promise_value(res) = val;
sexp_promise_value(res) = SEXP_VOID;
return res; return res;
} }
#endif #endif

33
lib/init-7.scm
View file

@ -308,10 +308,15 @@
,(map (lambda (x) (list (car x) (cadr x))) (cadr expr)) ,(map (lambda (x) (list (car x) (cadr x))) (cadr expr))
,wrap))))) ,wrap)))))
(define-syntax lazy
(er-macro-transformer
(lambda (expr rename compare)
`(,(rename 'make-promise) #f (,(rename 'lambda) () ,(cadr expr))))))
(define-syntax delay (define-syntax delay
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
`(,(rename 'make-promise) (,(rename 'lambda) () ,(cadr expr)))))) `(,(rename 'lazy) (,(rename 'make-promise) #t ,(cadr expr))))))
(define-syntax define-auxiliary-syntax (define-syntax define-auxiliary-syntax
(er-macro-transformer (er-macro-transformer
@ -896,17 +901,23 @@
(cond-expand (cond-expand
(auto-force (auto-force
(define (force x) x)) )
(else (else
(define (make-promise thunk) (define (make-promise done? proc)
(lambda () (list (cons done? proc)))
(let ((computed? #f) (result #f)) (define (promise-done? x) (car (car x)))
(if (not computed?) (define (promise-value x) (cdr (car x)))
(begin (define (promise-update! new old)
(set! result (thunk)) (set-car! (car old) (promise-done? new))
(set! computed? #t))) (set-cdr! (car old) (promise-value new))
result))) (set-car! new (car old)))
(define (force x) (if (procedure? x) (x) x)))) (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 ;; 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), _FN0(SEXP_VOID, "print-vm-profile", 0, sexp_print_vm_profile),
#endif #endif
#if SEXP_USE_AUTO_FORCE #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 #endif
}; };

5
vm.c
View file

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