[bpt/guile.git] / test-suite / tests / control.test

;;;;                                                          -*- scheme -*-
;;;; control.test --- test suite for delimited continuations
;;;;
;;;; Copyright (C) 2010, 2011, 2013 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-1)
  #: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/c&e "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))))

  (pass-if-equal "call/ec" '(0 1 2)            ; example from the manual
    (let ((prefix
           (lambda (x lst)
             (call/ec
              (lambda (return)
                (fold (lambda (element prefix)
                        (if (equal? element x)
                            (return (reverse prefix))
                            (cons element prefix)))
                      '()
                      lst))))))
      (prefix 'a '(0 1 2 a 3 4 5))))

  (pass-if-equal "let/ec" '(0 1 2)
    (let ((prefix
           (lambda (x lst)
             (let/ec return
               (fold (lambda (element prefix)
                       (if (equal? element x)
                           (return (reverse prefix))
                           (cons element prefix)))
                     '()
                     lst)))))
      (prefix 'a '(0 1 2 a 3 4 5)))))

;;; And the case in which the compiler has to reify the continuation.
(with-test-prefix/c&e "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)))))

  (pass-if "reified pending call frames, instantiated elsewhere on the stack"
    (equal? 'foo
            ((call-with-prompt
              'p0
              (lambda ()
                (identity ((abort-to-prompt 'p0) 'foo)))
              (lambda (c) c))
             (lambda (x) x)))))


;; The variants check different cases in the compiler.
(with-test-prefix/c&e "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))))

;; Here we test different cases for the `prompt'.
(with-test-prefix/c&e "prompt in different contexts"
  (pass-if "push, normal exit"
    (car (call-with-prompt
          'foo
          (lambda () '(#t))
          (lambda (k) '(#f)))))

  (pass-if "push, nonlocal exit"
    (car (call-with-prompt
          'foo
          (lambda () (abort-to-prompt 'foo) '(#f))
          (lambda (k) '(#t)))))

  (pass-if "push with RA, normal exit"
    (car (letrec ((test (lambda ()
                          (call-with-prompt
                           'foo
                           (lambda () '(#t))
                           (lambda (k) '(#f))))))
           (test))))

  (pass-if "push with RA, nonlocal exit"
    (car (letrec ((test (lambda ()
                          (call-with-prompt
                           'foo
                           (lambda () (abort-to-prompt 'foo) '(#f))
                           (lambda (k) '(#t))))))
           (test))))

  (pass-if "tail, normal exit"
    (call-with-prompt
     'foo
     (lambda () #t)
     (lambda (k) #f)))

  (pass-if "tail, nonlocal exit"
    (call-with-prompt
     'foo
     (lambda () (abort-to-prompt 'foo) #f)
     (lambda (k) #t)))

  (pass-if "tail with RA, normal exit"
    (letrec ((test (lambda ()
                     (call-with-prompt
                      'foo
                      (lambda () #t)
                      (lambda (k) #f)))))
      (test)))

  (pass-if "tail with RA, nonlocal exit"
    (letrec ((test (lambda ()
                     (call-with-prompt
                      'foo
                      (lambda () (abort-to-prompt 'foo) #f)
                      (lambda (k) #t)))))
      (test)))

  (pass-if "drop, normal exit"
    (begin
      (call-with-prompt
       'foo
       (lambda () #f)
       (lambda (k) #f))
      #t))

  (pass-if "drop, nonlocal exit"
    (begin
      (call-with-prompt
       'foo
       (lambda () (abort-to-prompt 'foo))
       (lambda (k) #f))
      #t))

  (pass-if "drop with RA, normal exit"
    (begin
      (letrec ((test (lambda ()
                       (call-with-prompt
                        'foo
                        (lambda () #f)
                        (lambda (k) #f)))))
        (test))
      #t))

  (pass-if "drop with RA, nonlocal exit"
    (begin
      (letrec ((test (lambda ()
                       (call-with-prompt
                        'foo
                        (lambda () (abort-to-prompt 'foo) #f)
                        (lambda (k) #f)))))
        (test))
      #t)))


(define fl (make-fluid))
(fluid-set! fl 0)

;; Not c&e as it assumes this block executes once.
;;
(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/c&e "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/c&e "abort to unknown prompt"
  (pass-if-exception "foo" '(misc-error . "^Abort to unknown prompt")
                     (abort-to-prompt 'does-not-exist)))

(with-test-prefix/c&e "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))))))

  (pass-if "stack overflow reinstates stack reserve"
    ;; In Guile <= 2.0.9, only the first overflow would be gracefully
    ;; handle; subsequent overflows would lead to an abort.  See
    ;; <http://lists.gnu.org/archive/html/guile-user/2013-12/msg00017.html>.
    (letrec ((foo (lambda () (+ 1 (foo)))))
      (define (overflows?)
        (catch 'vm-error foo
          (lambda (key proc msg . rest)
            (and (eq? 'vm-run proc)
                 (->bool (string-contains msg "overflow"))))))

      (and (overflows?) (overflows?) (overflows?)))))

;; These tests from Oleg Kiselyov's delim-control-n.scm, available at
;; http://okmij.org/ftp/Scheme/delim-control-n.scm.  Public domain.
;;
(with-test-prefix "shift and reset"
  (pass-if (equal?
            117
            (+ 10 (reset (+ 2 (shift k (+ 100 (k (k 3)))))))))

  (pass-if (equal?
            60
            (* 10 (reset (* 2 (shift g (* 5 (shift f (+ (f 1) 1)))))))))

  (pass-if (equal?
            121
            (let ((f (lambda (x) (shift k (k (k x))))))
              (+ 1 (reset (+ 10 (f 100)))))))

  (pass-if (equal?
            'a
            (car (reset
                  (let ((x (shift f
                                  (shift f1 (f1 (cons 'a (f '())))))))
                    (shift g x))))))
  
  ;; Example by Olivier Danvy
  (pass-if (equal?
            '(1 2 3 4 5)
            (let ()
              (define (traverse xs)
                (define (visit xs)
                  (if (null? xs)
                      '()
                      (visit (shift*
                              (lambda (k)
                                (cons (car xs) (k (cdr xs))))))))
                (reset* (lambda () (visit xs))))
              (traverse '(1 2 3 4 5))))))
Commit	Line	Data
ce4c9a6d AW	1	;;;; -- scheme --
	2	;;;; control.test --- test suite for delimited continuations
	3	;;;;
55e26a49	4	;;;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
ce4c9a6d AW	5	;;;;
	6	;;;; This library is free software; you can redistribute it and/or
	7	;;;; modify it under the terms of the GNU Lesser General Public
	8	;;;; License as published by the Free Software Foundation; either
	9	;;;; version 3 of the License, or (at your option) any later version.
	10	;;;;
	11	;;;; This library is distributed in the hope that it will be useful,
	12	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	13	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	14	;;;; Lesser General Public License for more details.
	15	;;;;
	16	;;;; You should have received a copy of the GNU Lesser General Public
	17	;;;; License along with this library; if not, write to the Free Software
	18	;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
	19
	20	(define-module (test-suite test-control)
	21	#:use-module (ice-9 control)
8684029d	22	#:use-module (system vm vm)
55e26a49	23	#:use-module (srfi srfi-1)
da7497e0	24	#:use-module (srfi srfi-11)
ce4c9a6d AW	25	#:use-module (test-suite lib))
	26
	27
da7fa082 AW	28	;; For these, the compiler should be able to prove that "k" is not referenced,
	29	;; so it avoids reifying the continuation. Since that's a slightly different
	30	;; codepath, we test them both.
f5fc7e57	31	(with-test-prefix/c&e "escape-only continuations"
ce4c9a6d AW	32	(pass-if "no values, normal exit"
	33	(equal? '()
	34	(call-with-values
	35	(lambda ()
8fc43b12	36	(% (values)
ce4c9a6d AW	37	(lambda (k . args)
	38	(error "unexpected exit" args))))
	39	list)))
da7fa082 AW	40
da7fa082 AW	41	(pass-if "no values, abnormal exit"
ce4c9a6d	42	(equal? '()
8fc43b12 AW	43	(% (begin
8fc43b12 AW	44	(abort)
ce4c9a6d	45	(error "unexpected exit"))
da7fa082 AW	46	(lambda (k . args)
	47	args))))
	48
	49	(pass-if "single value, normal exit"
	50	(equal? '(foo)
	51	(call-with-values
	52	(lambda ()
8fc43b12	53	(% 'foo
da7fa082 AW	54	(lambda (k . args)
	55	(error "unexpected exit" args))))
	56	list)))
	57
	58	(pass-if "single value, abnormal exit"
	59	(equal? '(foo)
8fc43b12 AW	60	(% (begin
8fc43b12 AW	61	(abort 'foo)
da7fa082 AW	62	(error "unexpected exit"))
	63	(lambda (k . args)
	64	args))))
	65
	66	(pass-if "multiple values, normal exit"
	67	(equal? '(foo bar baz)
	68	(call-with-values
	69	(lambda ()
8fc43b12	70	(% (values 'foo 'bar 'baz)
da7fa082 AW	71	(lambda (k . args)
	72	(error "unexpected exit" args))))
	73	list)))
	74
	75	(pass-if "multiple values, abnormal exit"
	76	(equal? '(foo bar baz)
8fc43b12 AW	77	(% (begin
8fc43b12 AW	78	(abort 'foo 'bar 'baz)
da7fa082	79	(error "unexpected exit"))
ce4c9a6d	80	(lambda (k . args)
55e26a49 LC	81	args))))
	82
	83	(pass-if-equal "call/ec" '(0 1 2) ; example from the manual
	84	(let ((prefix
	85	(lambda (x lst)
	86	(call/ec
	87	(lambda (return)
	88	(fold (lambda (element prefix)
	89	(if (equal? element x)
	90	(return (reverse prefix))
	91	(cons element prefix)))
	92	'()
	93	lst))))))
	94	(prefix 'a '(0 1 2 a 3 4 5))))
	95
	96	(pass-if-equal "let/ec" '(0 1 2)
	97	(let ((prefix
	98	(lambda (x lst)
	99	(let/ec return
	100	(fold (lambda (element prefix)
	101	(if (equal? element x)
	102	(return (reverse prefix))
	103	(cons element prefix)))
	104	'()
	105	lst)))))
	106	(prefix 'a '(0 1 2 a 3 4 5)))))
ce4c9a6d	107
da7fa082	108	;;; And the case in which the compiler has to reify the continuation.
f5fc7e57	109	(with-test-prefix/c&e "reified continuations"
da7fa082 AW	110	(pass-if "no values, normal exit"
	111	(equal? '()
	112	(call-with-values
	113	(lambda ()
8fc43b12	114	(% (values)
da7fa082 AW	115	(lambda (k . args)
	116	(error "unexpected exit" k args))))
	117	list)))
	118
	119	(pass-if "no values, abnormal exit"
	120	(equal? '()
	121	(cdr
8fc43b12 AW	122	(% (begin
8fc43b12 AW	123	(abort)
da7fa082 AW	124	(error "unexpected exit"))
	125	(lambda args
	126	args)))))
	127
	128	(pass-if "single value, normal exit"
	129	(equal? '(foo)
	130	(call-with-values
	131	(lambda ()
8fc43b12	132	(% 'foo
da7fa082 AW	133	(lambda (k . args)
	134	(error "unexpected exit" k args))))
	135	list)))
	136
	137	(pass-if "single value, abnormal exit"
	138	(equal? '(foo)
	139	(cdr
8fc43b12 AW	140	(% (begin
8fc43b12 AW	141	(abort 'foo)
da7fa082 AW	142	(error "unexpected exit"))
	143	(lambda args
	144	args)))))
	145
	146	(pass-if "multiple values, normal exit"
	147	(equal? '(foo bar baz)
	148	(call-with-values
	149	(lambda ()
8fc43b12	150	(% (values 'foo 'bar 'baz)
da7fa082 AW	151	(lambda (k . args)
	152	(error "unexpected exit" k args))))
	153	list)))
	154
	155	(pass-if "multiple values, abnormal exit"
	156	(equal? '(foo bar baz)
	157	(cdr
8fc43b12 AW	158	(% (begin
8fc43b12 AW	159	(abort 'foo 'bar 'baz)
da7fa082 AW	160	(error "unexpected exit"))
da7fa082 AW	161	(lambda args
f5fc7e57 AW	162	args)))))
	163
	164	(pass-if "reified pending call frames, instantiated elsewhere on the stack"
	165	(equal? 'foo
	166	((call-with-prompt
	167	'p0
	168	(lambda ()
	169	(identity ((abort-to-prompt 'p0) 'foo)))
	170	(lambda (c) c))
	171	(lambda (x) x)))))
	172
da7fa082	173
da7497e0	174	;; The variants check different cases in the compiler.
f5fc7e57	175	(with-test-prefix/c&e "restarting partial continuations"
da7497e0	176	(pass-if "in side-effect position"
8fc43b12	177	(let ((k (% (begin (abort) 'foo)
da7fa082 AW	178	(lambda (k) k))))
da7fa082 AW	179	(eq? (k)
da7497e0 AW	180	'foo)))
	181
	182	(pass-if "passing values to side-effect abort"
8fc43b12	183	(let ((k (% (begin (abort) 'foo)
da7497e0 AW	184	(lambda (k) k))))
	185	(eq? (k 'qux 'baz 'hello)
	186	'foo)))
	187
	188	(pass-if "called for one value"
8fc43b12	189	(let ((k (% (+ (abort) 3)
da7497e0 AW	190	(lambda (k) k))))
	191	(eqv? (k 39)
	192	42)))
	193
	194	(pass-if "called for multiple values"
8fc43b12	195	(let ((k (% (let-values (((a b . c) (abort)))
da7497e0 AW	196	(list a b c))
	197	(lambda (k) k))))
	198	(equal? (k 1 2 3 4)
	199	'(1 2 (3 4)))))
	200
	201	(pass-if "in tail position"
8fc43b12	202	(let ((k (% (abort)
da7497e0 AW	203	(lambda (k) k))))
	204	(eq? (k 'xyzzy)
	205	'xyzzy))))
da7fa082	206
9dadfa47 AW	207	;; Here we test different cases for the `prompt'.
	208	(with-test-prefix/c&e "prompt in different contexts"
	209	(pass-if "push, normal exit"
	210	(car (call-with-prompt
	211	'foo
	212	(lambda () '(#t))
	213	(lambda (k) '(#f)))))
	214
	215	(pass-if "push, nonlocal exit"
	216	(car (call-with-prompt
	217	'foo
	218	(lambda () (abort-to-prompt 'foo) '(#f))
	219	(lambda (k) '(#t)))))
	220
	221	(pass-if "push with RA, normal exit"
	222	(car (letrec ((test (lambda ()
	223	(call-with-prompt
	224	'foo
	225	(lambda () '(#t))
	226	(lambda (k) '(#f))))))
	227	(test))))
	228
	229	(pass-if "push with RA, nonlocal exit"
	230	(car (letrec ((test (lambda ()
	231	(call-with-prompt
	232	'foo
	233	(lambda () (abort-to-prompt 'foo) '(#f))
	234	(lambda (k) '(#t))))))
	235	(test))))
	236
	237	(pass-if "tail, normal exit"
	238	(call-with-prompt
	239	'foo
	240	(lambda () #t)
	241	(lambda (k) #f)))
	242
	243	(pass-if "tail, nonlocal exit"
	244	(call-with-prompt
	245	'foo
	246	(lambda () (abort-to-prompt 'foo) #f)
	247	(lambda (k) #t)))
	248
	249	(pass-if "tail with RA, normal exit"
	250	(letrec ((test (lambda ()
	251	(call-with-prompt
	252	'foo
	253	(lambda () #t)
	254	(lambda (k) #f)))))
	255	(test)))
	256
	257	(pass-if "tail with RA, nonlocal exit"
	258	(letrec ((test (lambda ()
	259	(call-with-prompt
	260	'foo
	261	(lambda () (abort-to-prompt 'foo) #f)
	262	(lambda (k) #t)))))
	263	(test)))
	264
	265	(pass-if "drop, normal exit"
	266	(begin
	267	(call-with-prompt
	268	'foo
	269	(lambda () #f)
	270	(lambda (k) #f))
271	#t))
272
273	(pass-if "drop, nonlocal exit"
274	(begin
275	(call-with-prompt
276	'foo
277	(lambda () (abort-to-prompt 'foo))
278	(lambda (k) #f))
279	#t))
280
281	(pass-if "drop with RA, normal exit"
282	(begin
283	(letrec ((test (lambda ()
284	(call-with-prompt
285	'foo
286	(lambda () #f)
287	(lambda (k) #f)))))
288	(test))
289	#t))
290
291	(pass-if "drop with RA, nonlocal exit"
292	(begin
293	(letrec ((test (lambda ()
294	(call-with-prompt
295	'foo
296	(lambda () (abort-to-prompt 'foo) #f)
297	(lambda (k) #f)))))
298	(test))
299	#t)))
300
301
da7fa082 AW	302	(define fl (make-fluid))
	303	(fluid-set! fl 0)
	304
f5fc7e57 AW	305	;; Not c&e as it assumes this block executes once.
f5fc7e57 AW	306	;;
da7fa082 AW	307	(with-test-prefix "suspend/resume with fluids"
da7fa082 AW	308	(pass-if "normal"
8fc43b12	309	(zero? (% (fluid-ref fl)
da7fa082 AW	310	error)))
da7fa082 AW	311	(pass-if "with-fluids normal"
8fc43b12	312	(equal? (% (with-fluids ((fl (1+ (fluid-ref fl))))
da7fa082 AW	313	(fluid-ref fl))
	314	error)
	315	1))
	316	(pass-if "normal (post)"
	317	(zero? (fluid-ref fl)))
	318	(pass-if "with-fluids and fluid-set!"
8fc43b12	319	(equal? (% (with-fluids ((fl (1+ (fluid-ref fl))))
da7fa082 AW	320	(fluid-set! fl (1+ (fluid-ref fl)))
	321	(fluid-ref fl))
	322	error)
	323	2))
	324	(pass-if "normal (post2)"
	325	(zero? (fluid-ref fl)))
	326	(pass-if "normal fluid-set!"
	327	(equal? (begin
	328	(fluid-set! fl (1+ (fluid-ref fl)))
	329	(fluid-ref fl))
	330	1))
	331	(pass-if "reset fluid-set!"
	332	(equal? (begin
	333	(fluid-set! fl (1- (fluid-ref fl)))
	334	(fluid-ref fl))
	335	0))
	336
8fc43b12 AW	337	(let ((k (% (with-fluids ((fl (1+ (fluid-ref fl))))
8fc43b12 AW	338	(abort)
da7fa082 AW	339	(fluid-ref fl))
	340	(lambda (k) k))))
	341	(pass-if "pre"
	342	(equal? (fluid-ref fl) 0))
	343	(pass-if "res"
	344	(equal? (k) 1))
	345	(pass-if "post"
	346	(equal? (fluid-ref fl) 0))))
adbdfd6d	347
f5fc7e57	348	(with-test-prefix/c&e "rewinding prompts"
adbdfd6d AW	349	(pass-if "nested prompts"
	350	(let ((k (% 'a
	351	(% 'b
	352	(begin
8fc43b12 AW	353	(abort-to-prompt 'a)
8fc43b12 AW	354	(abort-to-prompt 'b #t))
adbdfd6d AW	355	(lambda (k x) x))
	356	(lambda (k) k))))
	357	(k))))
9f074518	358
f5fc7e57	359	(with-test-prefix/c&e "abort to unknown prompt"
9f074518 AW	360	(pass-if-exception "foo" '(misc-error . "^Abort to unknown prompt")
9f074518 AW	361	(abort-to-prompt 'does-not-exist)))
8684029d	362
f5fc7e57	363	(with-test-prefix/c&e "the-vm"
8684029d LC	364
	365	(pass-if "unwind changes VMs"
	366	(let ((new-vm (make-vm))
	367	(prev-vm (the-vm))
	368	(proc (lambda (x y)
	369	(expt x y)))
	370	(call (lambda (p x y)
	371	(p x y))))
	372	(catch 'foo
	373	(lambda ()
ea9f4f4b	374	(call-with-vm new-vm (lambda () (throw 'foo (the-vm)))))
8684029d LC	375	(lambda (key vm)
	376	(and (eq? key 'foo)
	377	(eq? vm new-vm)
70057f34 LC	378	(eq? (the-vm) prev-vm))))))
	379
	380	(pass-if "stack overflow reinstates stack reserve"
	381	;; In Guile <= 2.0.9, only the first overflow would be gracefully
	382	;; handle; subsequent overflows would lead to an abort. See
	383	;; <http://lists.gnu.org/archive/html/guile-user/2013-12/msg00017.html>.
	384	(letrec ((foo (lambda () (+ 1 (foo)))))
	385	(define (overflows?)
	386	(catch 'vm-error foo
	387	(lambda (key proc msg . rest)
	388	(and (eq? 'vm-run proc)
	389	(->bool (string-contains msg "overflow"))))))
	390
	391	(and (overflows?) (overflows?) (overflows?)))))
18e444b4 AW	392
	393	;; These tests from Oleg Kiselyov's delim-control-n.scm, available at
	394	;; http://okmij.org/ftp/Scheme/delim-control-n.scm. Public domain.
	395	;;
	396	(with-test-prefix "shift and reset"
	397	(pass-if (equal?
	398	117
	399	(+ 10 (reset (+ 2 (shift k (+ 100 (k (k 3)))))))))
	400
	401	(pass-if (equal?
	402	60
	403	(* 10 (reset (* 2 (shift g (* 5 (shift f (+ (f 1) 1)))))))))
	404
	405	(pass-if (equal?
	406	121
	407	(let ((f (lambda (x) (shift k (k (k x))))))
	408	(+ 1 (reset (+ 10 (f 100)))))))
	409
	410	(pass-if (equal?
	411	'a
	412	(car (reset
	413	(let ((x (shift f
	414	(shift f1 (f1 (cons 'a (f '())))))))
	415	(shift g x))))))
	416
	417	;; Example by Olivier Danvy
	418	(pass-if (equal?
	419	'(1 2 3 4 5)
	420	(let ()
	421	(define (traverse xs)
	422	(define (visit xs)
	423	(if (null? xs)
	424	'()
	425	(visit (shift*
	426	(lambda (k)
	427	(cons (car xs) (k (cdr xs))))))))
	428	(reset* (lambda () (visit xs))))
	429	(traverse '(1 2 3 4 5))))))