mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-23 03:54:12 +02:00
adbdfd6d24
* libguile/control.h (SCM_PROMPT_HANDLER): Remove, it was unused.
(SCM_PROMPT_DYNWINDS): Rename from SCM_PROMPT_DYNENV.
* libguile/control.c: (scm_c_make_prompt): Take another arg, the winds
that are to be in place for the prompt. Fix allocation to be 4 words
instead of 5 (the handler was never used).
* libguile/eval.c (eval):
* libguile/throw.c (pre_init_catch): Adapt to scm_c_make_prompt change.
* libguile/vm-i-system.c (partial-cont-call): Grovel the new elements of
the wind list in order to call setjmp() on the new prompts. Pass
cookie to vm_reinstate_partial_continuation.
(prompt): Adapt to scm_c_make_prompt change.
* libguile/vm.c (vm_reinstate_partial_continuation): Take a cookie arg,
used when winding captured prompts onto the stack. Winding a prompt
implies making a new prompt, actually -- with new registers, a new
jump buffer, new winds, etc.
* test-suite/tests/control.test ("rewinding prompts"): Add a test for
rewinding prompts.
217 lines
6.7 KiB
Scheme
217 lines
6.7 KiB
Scheme
;;;; -*- scheme -*-
|
|
;;;; control.test --- test suite for delimited continuations
|
|
;;;;
|
|
;;;; Copyright (C) 2010 Free Software Foundation, Inc.
|
|
;;;;
|
|
;;;; This library is free software; you can redistribute it and/or
|
|
;;;; modify it under the terms of the GNU Lesser General Public
|
|
;;;; License as published by the Free Software Foundation; either
|
|
;;;; version 3 of the License, or (at your option) any later version.
|
|
;;;;
|
|
;;;; This library is distributed in the hope that it will be useful,
|
|
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;;;; Lesser General Public License for more details.
|
|
;;;;
|
|
;;;; You should have received a copy of the GNU Lesser General Public
|
|
;;;; License along with this library; if not, write to the Free Software
|
|
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
|
|
|
(define-module (test-suite test-control)
|
|
#:use-module (ice-9 control)
|
|
#:use-module (test-suite lib))
|
|
|
|
|
|
(define default-tag (fluid-ref %default-prompt-tag))
|
|
|
|
|
|
;; For these, the compiler should be able to prove that "k" is not referenced,
|
|
;; so it avoids reifying the continuation. Since that's a slightly different
|
|
;; codepath, we test them both.
|
|
(with-test-prefix "escape-only continuations"
|
|
(pass-if "no values, normal exit"
|
|
(equal? '()
|
|
(call-with-values
|
|
(lambda ()
|
|
(% default-tag
|
|
(values)
|
|
(lambda (k . args)
|
|
(error "unexpected exit" args))))
|
|
list)))
|
|
|
|
(pass-if "no values, abnormal exit"
|
|
(equal? '()
|
|
(% default-tag
|
|
(begin
|
|
(abort default-tag)
|
|
(error "unexpected exit"))
|
|
(lambda (k . args)
|
|
args))))
|
|
|
|
(pass-if "single value, normal exit"
|
|
(equal? '(foo)
|
|
(call-with-values
|
|
(lambda ()
|
|
(% default-tag
|
|
'foo
|
|
(lambda (k . args)
|
|
(error "unexpected exit" args))))
|
|
list)))
|
|
|
|
(pass-if "single value, abnormal exit"
|
|
(equal? '(foo)
|
|
(% default-tag
|
|
(begin
|
|
(abort default-tag 'foo)
|
|
(error "unexpected exit"))
|
|
(lambda (k . args)
|
|
args))))
|
|
|
|
(pass-if "multiple values, normal exit"
|
|
(equal? '(foo bar baz)
|
|
(call-with-values
|
|
(lambda ()
|
|
(% default-tag
|
|
(values 'foo 'bar 'baz)
|
|
(lambda (k . args)
|
|
(error "unexpected exit" args))))
|
|
list)))
|
|
|
|
(pass-if "multiple values, abnormal exit"
|
|
(equal? '(foo bar baz)
|
|
(% default-tag
|
|
(begin
|
|
(abort default-tag 'foo 'bar 'baz)
|
|
(error "unexpected exit"))
|
|
(lambda (k . args)
|
|
args)))))
|
|
|
|
;;; And the case in which the compiler has to reify the continuation.
|
|
(with-test-prefix "reified continuations"
|
|
(pass-if "no values, normal exit"
|
|
(equal? '()
|
|
(call-with-values
|
|
(lambda ()
|
|
(% default-tag
|
|
(values)
|
|
(lambda (k . args)
|
|
(error "unexpected exit" k args))))
|
|
list)))
|
|
|
|
(pass-if "no values, abnormal exit"
|
|
(equal? '()
|
|
(cdr
|
|
(% default-tag
|
|
(begin
|
|
(abort default-tag)
|
|
(error "unexpected exit"))
|
|
(lambda args
|
|
args)))))
|
|
|
|
(pass-if "single value, normal exit"
|
|
(equal? '(foo)
|
|
(call-with-values
|
|
(lambda ()
|
|
(% default-tag
|
|
'foo
|
|
(lambda (k . args)
|
|
(error "unexpected exit" k args))))
|
|
list)))
|
|
|
|
(pass-if "single value, abnormal exit"
|
|
(equal? '(foo)
|
|
(cdr
|
|
(% default-tag
|
|
(begin
|
|
(abort default-tag 'foo)
|
|
(error "unexpected exit"))
|
|
(lambda args
|
|
args)))))
|
|
|
|
(pass-if "multiple values, normal exit"
|
|
(equal? '(foo bar baz)
|
|
(call-with-values
|
|
(lambda ()
|
|
(% default-tag
|
|
(values 'foo 'bar 'baz)
|
|
(lambda (k . args)
|
|
(error "unexpected exit" k args))))
|
|
list)))
|
|
|
|
(pass-if "multiple values, abnormal exit"
|
|
(equal? '(foo bar baz)
|
|
(cdr
|
|
(% default-tag
|
|
(begin
|
|
(abort default-tag 'foo 'bar 'baz)
|
|
(error "unexpected exit"))
|
|
(lambda args
|
|
args))))))
|
|
|
|
;;; Here we test that instantiation works
|
|
(with-test-prefix "restarting partial continuations"
|
|
(pass-if "simple"
|
|
(let ((k (% default-tag
|
|
(begin (abort default-tag) 'foo)
|
|
(lambda (k) k))))
|
|
(eq? (k)
|
|
'foo))))
|
|
|
|
(define fl (make-fluid))
|
|
(fluid-set! fl 0)
|
|
|
|
(with-test-prefix "suspend/resume with fluids"
|
|
(pass-if "normal"
|
|
(zero? (% default-tag
|
|
(fluid-ref fl)
|
|
error)))
|
|
(pass-if "with-fluids normal"
|
|
(equal? (% default-tag
|
|
(with-fluids ((fl (1+ (fluid-ref fl))))
|
|
(fluid-ref fl))
|
|
error)
|
|
1))
|
|
(pass-if "normal (post)"
|
|
(zero? (fluid-ref fl)))
|
|
(pass-if "with-fluids and fluid-set!"
|
|
(equal? (% default-tag
|
|
(with-fluids ((fl (1+ (fluid-ref fl))))
|
|
(fluid-set! fl (1+ (fluid-ref fl)))
|
|
(fluid-ref fl))
|
|
error)
|
|
2))
|
|
(pass-if "normal (post2)"
|
|
(zero? (fluid-ref fl)))
|
|
(pass-if "normal fluid-set!"
|
|
(equal? (begin
|
|
(fluid-set! fl (1+ (fluid-ref fl)))
|
|
(fluid-ref fl))
|
|
1))
|
|
(pass-if "reset fluid-set!"
|
|
(equal? (begin
|
|
(fluid-set! fl (1- (fluid-ref fl)))
|
|
(fluid-ref fl))
|
|
0))
|
|
|
|
(let ((k (% default-tag
|
|
(with-fluids ((fl (1+ (fluid-ref fl))))
|
|
(abort default-tag)
|
|
(fluid-ref fl))
|
|
(lambda (k) k))))
|
|
(pass-if "pre"
|
|
(equal? (fluid-ref fl) 0))
|
|
(pass-if "res"
|
|
(equal? (k) 1))
|
|
(pass-if "post"
|
|
(equal? (fluid-ref fl) 0))))
|
|
|
|
(with-test-prefix "rewinding prompts"
|
|
(pass-if "nested prompts"
|
|
(let ((k (% 'a
|
|
(% 'b
|
|
(begin
|
|
(abort 'a)
|
|
(abort 'b #t))
|
|
(lambda (k x) x))
|
|
(lambda (k) k))))
|
|
(k))))
|