78 lines
2.9 KiB
Scheme
78 lines
2.9 KiB
Scheme
#lang scheme
|
|
(require scheme/system)
|
|
|
|
#|
|
|
|
|
This test is designed to to check whether meta-continuations are
|
|
correctly split when a continuation is delimited in the middle of
|
|
a meta-continuation other than the current one. In particular,
|
|
the `x' binding is part of the deeper meta-continuation when `ak'
|
|
is captured, but it is delimited inside the binding, so `x'
|
|
should not be reated in `ak'.
|
|
|
|
The test is implemented using `dump-memory-stats' in another mzscheme
|
|
process.
|
|
|
|
|#
|
|
|
|
(when (equal? #() (current-command-line-arguments))
|
|
(let ([f (find-executable-path (find-system-path 'exec-file) #f)])
|
|
(let ([p (open-output-bytes)])
|
|
(parameterize ([current-error-port p])
|
|
(system* f "-l" "tests/mzscheme/prompt-sfs" "sub"))
|
|
(unless (regexp-match? #rx"<will-executor>: +1 +" (get-output-bytes p))
|
|
(error "wrong output")
|
|
(exit 1))))
|
|
(exit 0))
|
|
|
|
(define (make-big-thing) (cons (make-string 100000) (make-will-executor)))
|
|
(define (show-big-thing say x) (say (string-length (car x))))
|
|
|
|
(collect-garbage)
|
|
(collect-garbage)
|
|
(define orig (current-memory-use))
|
|
|
|
(define single (make-will-executor))
|
|
|
|
(let loop ([n 10][accums null])
|
|
(if (zero? n)
|
|
(begin
|
|
(collect-garbage)
|
|
(collect-garbage)
|
|
(dump-memory-stats) ; look for just one <will-executor>
|
|
(printf "~s\n" (- (current-memory-use) orig))
|
|
accums)
|
|
(let* ([says null]
|
|
[say (lambda (s)
|
|
(set! says (cons s says)))]
|
|
[a (make-continuation-prompt-tag 'a)]
|
|
[b (make-continuation-prompt-tag 'b)])
|
|
(let ([ak
|
|
(let ([x (make-big-thing)])
|
|
(begin0
|
|
(call-with-continuation-prompt
|
|
(lambda ()
|
|
(with-continuation-mark 'y "y0"
|
|
(let ([bk (call-with-continuation-prompt
|
|
(lambda ()
|
|
(let ([f (call-with-composable-continuation
|
|
(lambda (k)
|
|
(lambda () k))
|
|
b)])
|
|
(say "bcall")
|
|
(begin0
|
|
(f)
|
|
(say "breturn"))))
|
|
b)])
|
|
(call-with-continuation-prompt
|
|
(lambda ()
|
|
((bk (lambda ()
|
|
(let ([f (call/cc (lambda (k) (lambda () (lambda () k))) a)])
|
|
(begin0
|
|
(f)
|
|
(say "areturn")))))))
|
|
b))))
|
|
a)
|
|
(show-big-thing say x)))])
|
|
(loop (sub1 n) (cons ak accums))))))
|