guile/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))))

  (pass-if "loop only in handler"
    (let ((n #f))
      (let lp ()
        (or n
            (call-with-prompt 'foo
              (lambda ()
                (set! n #t)
                (abort-to-prompt 'foo))
              (lambda (k) (lp))))))))

;;; 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 "unwind"

  (pass-if "unwind through call-with-vm"
    (let ((proc    (lambda (x y)
                     (expt x y)))
          (call    (lambda (p x y)
                     (p x y))))
      (catch 'foo
        (lambda ()
          (call-with-vm (lambda () (throw 'foo))))
        (lambda (key)
          (eq? key 'foo))))))

;; 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))))))

(with-test-prefix "suspendable-continuation?"
  (let ((tag (make-prompt-tag)))
    (pass-if "escape-only"
      (call-with-prompt tag
        (lambda ()
          (suspendable-continuation? tag))
        (lambda _ (error "unreachable"))))
    (pass-if "full"
      (call-with-prompt tag
        (lambda ()
          (suspendable-continuation? tag))
        (lambda (k) (error "unreachable" k))))
    (pass-if "escape-only with barrier"
      (call-with-prompt tag
        (lambda ()
          (with-continuation-barrier
           (lambda ()
             (not (suspendable-continuation? tag)))))
        (lambda _ (error "unreachable"))))
    (pass-if "full with barrier"
      (call-with-prompt tag
        (lambda ()
          (with-continuation-barrier
           (lambda ()
             (not (suspendable-continuation? tag)))))
        (lambda (k) (error "unreachable" k))))))