diff options
author | Andy Wingo <wingo@pobox.com> | 2008-09-26 13:42:09 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2008-09-26 13:42:09 +0200 |
commit | 7ff017002ddc980f684120653549a10c6c7cde5c (patch) | |
tree | 8ec1abe62c76cb06142e574b6560d693ba300c47 | |
parent | 107139eaadab946e9713748cdeacd07b22a181db (diff) | |
download | guile-7ff017002ddc980f684120653549a10c6c7cde5c.tar.gz |
Fix continuation marking, and some tests.
* libguile/continuations.c (continuation_mark): Mark the vm
continuations.
* libguile/vm.c (vm_cont_mark): Fix the marking function.
(vm_mark): Fix this one too -- the size is a number of STACKITEMS,
which we foolishly assume are the same size as SCM.
* test-suite/tests/ftw.test: Make our stat hacks verifyable without
assuming that they are interpreted.
* test-suite/tests/r5rs_pitfall.test: Re-indent.
-rw-r--r-- | libguile/continuations.c | 1 | ||||
-rw-r--r-- | libguile/vm.c | 8 | ||||
-rw-r--r-- | test-suite/tests/ftw.test | 15 | ||||
-rw-r--r-- | test-suite/tests/r5rs_pitfall.test | 32 |
4 files changed, 28 insertions, 28 deletions
diff --git a/libguile/continuations.c b/libguile/continuations.c index db6eebbe6..cbe97a292 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -51,6 +51,7 @@ continuation_mark (SCM obj) scm_gc_mark (continuation->root); scm_gc_mark (continuation->throw_value); + scm_gc_mark (continuation->vm_conts); scm_mark_locations (continuation->stack, continuation->num_stack_items); #ifdef __ia64__ if (continuation->backing_store) diff --git a/libguile/vm.c b/libguile/vm.c index 161225b14..c14fb3b45 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -80,16 +80,14 @@ struct scm_vm_cont { static SCM vm_cont_mark (SCM obj) { - scm_t_ptrdiff i, size; + size_t size; SCM *stack; stack = SCM_VM_CONT_DATA (obj)->stack_base; size = SCM_VM_CONT_DATA (obj)->stack_size; /* we could be smarter about this. */ - for (i = 0; i < size; i ++) - if (SCM_NIMP (stack[i])) - scm_gc_mark (stack[i]); + scm_mark_locations ((SCM_STACKITEM *) stack, size); return SCM_BOOL_F; } @@ -333,7 +331,7 @@ vm_mark (SCM obj) /* mark the stack conservatively */ scm_mark_locations ((SCM_STACKITEM *) vp->stack_base, - sizeof (SCM) * (vp->sp - vp->stack_base + 1)); + vp->sp - vp->stack_base + 1); /* mark other objects */ for (i = 0; i < SCM_VM_NUM_HOOKS; i++) diff --git a/test-suite/tests/ftw.test b/test-suite/tests/ftw.test index a61850af2..c0cbb92cd 100644 --- a/test-suite/tests/ftw.test +++ b/test-suite/tests/ftw.test @@ -25,18 +25,19 @@ ;; what ice-9/posix.scm stat:dev and stat:ino do (which in turn match ;; libguile/filesys.c of course) -(or (equal? (procedure-source stat:dev) - '(lambda (f) (vector-ref f 0))) - (error "oops, unexpected stat:dev definition")) (define (stat:dev! st dev) (vector-set! st 0 dev)) - -(or (equal? (procedure-source stat:ino) - '(lambda (f) (vector-ref f 1))) - (error "oops, unexpected stat:ino definition")) (define (stat:ino! st ino) (vector-set! st 1 ino)) +(let* ((s (stat "/")) + (i (stat:ino s)) + (d (stat:dev s))) + (stat:ino! s (1+ i)) + (stat:dev! s (1+ d)) + (if (not (and (= (stat:ino s) (1+ i)) + (= (stat:dev s) (1+ d)))) + (error "unexpected definitions of stat:dev and stat:ino"))) ;; ;; visited?-proc diff --git a/test-suite/tests/r5rs_pitfall.test b/test-suite/tests/r5rs_pitfall.test index 8fa78e9c1..1357345b2 100644 --- a/test-suite/tests/r5rs_pitfall.test +++ b/test-suite/tests/r5rs_pitfall.test @@ -27,15 +27,15 @@ (syntax-rules () ((_ test-id value expression) (run-test test-id #t (lambda () - (false-if-exception - (equal? expression value))))))) + (false-if-exception + (equal? expression value))))))) (define-syntax should-be-but-isnt (syntax-rules () ((_ test-id value expression) (run-test test-id #f (lambda () - (false-if-exception - (equal? expression value))))))) + (false-if-exception + (equal? expression value))))))) (define call/cc call-with-current-continuation) @@ -65,7 +65,7 @@ (should-be 1.2 #t (letrec ((x (call/cc list)) (y (call/cc list))) (cond ((procedure? x) (x (pair? y))) - ((procedure? y) (y (pair? x)))) + ((procedure? y) (y (pair? x)))) (let ((x (car x)) (y (car y))) (and (call/cc x) (call/cc y) (call/cc x))))) @@ -75,11 +75,11 @@ ;; http://groups.google.com/groups?selm=19890302162742.4.ALAN%40PIGPEN.AI.MIT.EDU (should-be 1.3 #t (letrec ((x (call-with-current-continuation - (lambda (c) - (list #T c))))) + (lambda (c) + (list #T c))))) (if (car x) - ((cadr x) (list #F (lambda () x))) - (eq? x ((cadr x)))))) + ((cadr x) (list #F (lambda () x))) + (eq? x ((cadr x)))))) ;; Section 2: Proper call/cc and procedure application @@ -300,12 +300,12 @@ (define res1 #f) (define res2 #f) (set! res1 (map (lambda (x) - (if (= x 0) - (call/cc (lambda (k) (set! cont k) 0)) - 0)) - '(1 0 2))) + (if (= x 0) + (call/cc (lambda (k) (set! cont k) 0)) + 0)) + '(1 0 2))) (if (not executed-k) - (begin (set! executed-k #t) - (set! res2 res1) - (cont 1))) + (begin (set! executed-k #t) + (set! res2 res1) + (cont 1))) res2)) |