summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2008-09-26 13:42:09 +0200
committerAndy Wingo <wingo@pobox.com>2008-09-26 13:42:09 +0200
commit7ff017002ddc980f684120653549a10c6c7cde5c (patch)
tree8ec1abe62c76cb06142e574b6560d693ba300c47
parent107139eaadab946e9713748cdeacd07b22a181db (diff)
downloadguile-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.c1
-rw-r--r--libguile/vm.c8
-rw-r--r--test-suite/tests/ftw.test15
-rw-r--r--test-suite/tests/r5rs_pitfall.test32
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))