mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-02 21:10:27 +02:00
ea9f4f4b15
* libguile/vm.h (scm_c_vm_run): Make internal.
* libguile/vm.c (vm_default_engine): New static global variable.
(make_vm): Set vp->engine based on
(scm_vm_apply): Remove in favor of call-with-vm.
(scm_thread_vm, scm_set_thread_vm_x): Remove these, as they did not
have a well-defined meaning, and were dangerous to call on other
threads.
(scm_the_vm): Reinstate previous definition.
(symbol_to_vm_engine, vm_engine_to_symbol)
(vm_has_pending_computation): New helpers.
(scm_vm_engine, scm_set_vm_engine_x, scm_c_set_vm_engine_x): New
accessors for VM engines.
(scm_c_set_default_vm_engine_x, scm_set_default_vm_engine_x): New
setters for the default VM engine.
(scm_call_with_vm): New function, applies a procedure to arguments in
a context in which a given VM is current.
* libguile/eval.c (eval, scm_apply): VM dispatch goes through
scm_call_with_vm.
* test-suite/tests/control.test ("the-vm"):
* module/system/vm/coverage.scm (with-code-coverage): Use call-with-vm.
* module/system/vm/vm.scm: Update exports.
* test-suite/vm/run-vm-tests.scm (run-vm-program):
* test-suite/tests/compiler.test ("current-reader"): Just rely on the
result of make-program being an applicable.
* test-suite/tests/eval.test ("stack overflow"): Add a note that this
test does not test what it should.
245 lines
7.4 KiB
Scheme
245 lines
7.4 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 (system vm vm)
|
|
#:use-module (srfi srfi-11)
|
|
#:use-module (test-suite lib))
|
|
|
|
|
|
;; 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 ()
|
|
(% (values)
|
|
(lambda (k . args)
|
|
(error "unexpected exit" args))))
|
|
list)))
|
|
|
|
(pass-if "no values, abnormal exit"
|
|
(equal? '()
|
|
(% (begin
|
|
(abort)
|
|
(error "unexpected exit"))
|
|
(lambda (k . args)
|
|
args))))
|
|
|
|
(pass-if "single value, normal exit"
|
|
(equal? '(foo)
|
|
(call-with-values
|
|
(lambda ()
|
|
(% 'foo
|
|
(lambda (k . args)
|
|
(error "unexpected exit" args))))
|
|
list)))
|
|
|
|
(pass-if "single value, abnormal exit"
|
|
(equal? '(foo)
|
|
(% (begin
|
|
(abort 'foo)
|
|
(error "unexpected exit"))
|
|
(lambda (k . args)
|
|
args))))
|
|
|
|
(pass-if "multiple values, normal exit"
|
|
(equal? '(foo bar baz)
|
|
(call-with-values
|
|
(lambda ()
|
|
(% (values 'foo 'bar 'baz)
|
|
(lambda (k . args)
|
|
(error "unexpected exit" args))))
|
|
list)))
|
|
|
|
(pass-if "multiple values, abnormal exit"
|
|
(equal? '(foo bar baz)
|
|
(% (begin
|
|
(abort '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 ()
|
|
(% (values)
|
|
(lambda (k . args)
|
|
(error "unexpected exit" k args))))
|
|
list)))
|
|
|
|
(pass-if "no values, abnormal exit"
|
|
(equal? '()
|
|
(cdr
|
|
(% (begin
|
|
(abort)
|
|
(error "unexpected exit"))
|
|
(lambda args
|
|
args)))))
|
|
|
|
(pass-if "single value, normal exit"
|
|
(equal? '(foo)
|
|
(call-with-values
|
|
(lambda ()
|
|
(% 'foo
|
|
(lambda (k . args)
|
|
(error "unexpected exit" k args))))
|
|
list)))
|
|
|
|
(pass-if "single value, abnormal exit"
|
|
(equal? '(foo)
|
|
(cdr
|
|
(% (begin
|
|
(abort 'foo)
|
|
(error "unexpected exit"))
|
|
(lambda args
|
|
args)))))
|
|
|
|
(pass-if "multiple values, normal exit"
|
|
(equal? '(foo bar baz)
|
|
(call-with-values
|
|
(lambda ()
|
|
(% (values 'foo 'bar 'baz)
|
|
(lambda (k . args)
|
|
(error "unexpected exit" k args))))
|
|
list)))
|
|
|
|
(pass-if "multiple values, abnormal exit"
|
|
(equal? '(foo bar baz)
|
|
(cdr
|
|
(% (begin
|
|
(abort 'foo 'bar 'baz)
|
|
(error "unexpected exit"))
|
|
(lambda args
|
|
args))))))
|
|
|
|
;; The variants check different cases in the compiler.
|
|
(with-test-prefix "restarting partial continuations"
|
|
(pass-if "in side-effect position"
|
|
(let ((k (% (begin (abort) 'foo)
|
|
(lambda (k) k))))
|
|
(eq? (k)
|
|
'foo)))
|
|
|
|
(pass-if "passing values to side-effect abort"
|
|
(let ((k (% (begin (abort) 'foo)
|
|
(lambda (k) k))))
|
|
(eq? (k 'qux 'baz 'hello)
|
|
'foo)))
|
|
|
|
(pass-if "called for one value"
|
|
(let ((k (% (+ (abort) 3)
|
|
(lambda (k) k))))
|
|
(eqv? (k 39)
|
|
42)))
|
|
|
|
(pass-if "called for multiple values"
|
|
(let ((k (% (let-values (((a b . c) (abort)))
|
|
(list a b c))
|
|
(lambda (k) k))))
|
|
(equal? (k 1 2 3 4)
|
|
'(1 2 (3 4)))))
|
|
|
|
(pass-if "in tail position"
|
|
(let ((k (% (abort)
|
|
(lambda (k) k))))
|
|
(eq? (k 'xyzzy)
|
|
'xyzzy))))
|
|
|
|
(define fl (make-fluid))
|
|
(fluid-set! fl 0)
|
|
|
|
(with-test-prefix "suspend/resume with fluids"
|
|
(pass-if "normal"
|
|
(zero? (% (fluid-ref fl)
|
|
error)))
|
|
(pass-if "with-fluids normal"
|
|
(equal? (% (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? (% (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 (% (with-fluids ((fl (1+ (fluid-ref fl))))
|
|
(abort)
|
|
(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-to-prompt 'a)
|
|
(abort-to-prompt 'b #t))
|
|
(lambda (k x) x))
|
|
(lambda (k) k))))
|
|
(k))))
|
|
|
|
(with-test-prefix "abort to unknown prompt"
|
|
(pass-if-exception "foo" '(misc-error . "^Abort to unknown prompt")
|
|
(abort-to-prompt 'does-not-exist)))
|
|
|
|
(with-test-prefix "the-vm"
|
|
|
|
(pass-if "unwind changes VMs"
|
|
(let ((new-vm (make-vm))
|
|
(prev-vm (the-vm))
|
|
(proc (lambda (x y)
|
|
(expt x y)))
|
|
(call (lambda (p x y)
|
|
(p x y))))
|
|
(catch 'foo
|
|
(lambda ()
|
|
(call-with-vm new-vm (lambda () (throw 'foo (the-vm)))))
|
|
(lambda (key vm)
|
|
(and (eq? key 'foo)
|
|
(eq? vm new-vm)
|
|
(eq? (the-vm) prev-vm)))))))
|