test-suite/tests/control.test

   1 ;;;;                                                          -*- scheme -*-
   2 ;;;; control.test --- test suite for delimited continuations
   3 ;;;;
   4 ;;;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc.
   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)
  22   #:use-module (system vm vm)
  23   #:use-module (srfi srfi-1)
  24   #:use-module (srfi srfi-11)
  25   #:use-module (test-suite lib))
  26
  27
  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.
  31 (with-test-prefix/c&e "escape-only continuations"
  32   (pass-if "no values, normal exit"
  33     (equal? '()
  34             (call-with-values
  35                 (lambda ()
  36                   (% (values)
  37                      (lambda (k . args)
  38                        (error "unexpected exit" args))))
  39               list)))
  40
  41   (pass-if "no values, abnormal exit"
  42     (equal? '()
  43             (% (begin
  44                  (abort)
  45                  (error "unexpected exit"))
  46                (lambda (k . args)
  47                  args))))
  48
  49   (pass-if "single value, normal exit"
  50     (equal? '(foo)
  51             (call-with-values
  52                 (lambda ()
  53                   (% 'foo
  54                      (lambda (k . args)
  55                        (error "unexpected exit" args))))
  56               list)))
  57
  58   (pass-if "single value, abnormal exit"
  59     (equal? '(foo)
  60             (% (begin
  61                  (abort 'foo)
  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 ()
  70                   (% (values 'foo 'bar 'baz)
  71                      (lambda (k . args)
  72                        (error "unexpected exit" args))))
  73               list)))
  74
  75   (pass-if "multiple values, abnormal exit"
  76     (equal? '(foo bar baz)
  77             (% (begin
  78                  (abort 'foo 'bar 'baz)
  79                  (error "unexpected exit"))
  80                (lambda (k . args)
  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)))))
 107
 108 ;;; And the case in which the compiler has to reify the continuation.
 109 (with-test-prefix/c&e "reified continuations"
 110   (pass-if "no values, normal exit"
 111     (equal? '()
 112             (call-with-values
 113                 (lambda ()
 114                   (% (values)
 115                      (lambda (k . args)
 116                        (error "unexpected exit" k args))))
 117               list)))
 118
 119   (pass-if "no values, abnormal exit"
 120     (equal? '()
 121             (cdr
 122              (% (begin
 123                   (abort)
 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 ()
 132                   (% 'foo
 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
 140              (% (begin
 141                   (abort 'foo)
 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 ()
 150                   (% (values 'foo 'bar 'baz)
 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
 158              (% (begin
 159                   (abort 'foo 'bar 'baz)
 160                   (error "unexpected exit"))
 161                 (lambda args
 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
 173
 174 ;; The variants check different cases in the compiler.
 175 (with-test-prefix/c&e "restarting partial continuations"
 176   (pass-if "in side-effect position"
 177     (let ((k (% (begin (abort) 'foo)
 178                 (lambda (k) k))))
 179       (eq? (k)
 180            'foo)))
 181
 182   (pass-if "passing values to side-effect abort"
 183     (let ((k (% (begin (abort) 'foo)
 184                 (lambda (k) k))))
 185       (eq? (k 'qux 'baz 'hello)
 186            'foo)))
 187
 188   (pass-if "called for one value"
 189     (let ((k (% (+ (abort) 3)
 190                 (lambda (k) k))))
 191       (eqv? (k 39)
 192             42)))
 193
 194   (pass-if "called for multiple values"
 195     (let ((k (% (let-values (((a b . c) (abort)))
 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"
 202     (let ((k (% (abort)
 203                 (lambda (k) k))))
 204       (eq? (k 'xyzzy)
 205            'xyzzy))))
 206
 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
 302 (define fl (make-fluid))
 303 (fluid-set! fl 0)
 304
 305 ;; Not c&e as it assumes this block executes once.
 306 ;;
 307 (with-test-prefix "suspend/resume with fluids"
 308   (pass-if "normal"
 309     (zero? (% (fluid-ref fl)
 310               error)))
 311   (pass-if "with-fluids normal"
 312     (equal? (% (with-fluids ((fl (1+ (fluid-ref fl))))
 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!"
 319     (equal? (% (with-fluids ((fl (1+ (fluid-ref fl))))
 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
 337   (let ((k (% (with-fluids ((fl (1+ (fluid-ref fl))))
 338                 (abort)
 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))))
 347
 348 (with-test-prefix/c&e "rewinding prompts"
 349   (pass-if "nested prompts"
 350     (let ((k (% 'a
 351                 (% 'b
 352                    (begin
 353                      (abort-to-prompt 'a)
 354                      (abort-to-prompt 'b #t))
 355                    (lambda (k x) x))
 356                 (lambda (k) k))))
 357       (k))))
 358
 359 (with-test-prefix/c&e "abort to unknown prompt"
 360   (pass-if-exception "foo" '(misc-error . "^Abort to unknown prompt")
 361                      (abort-to-prompt 'does-not-exist)))
 362
 363 (with-test-prefix/c&e "unwind"
 364
 365   (pass-if "unwind through call-with-vm"
 366     (let ((proc    (lambda (x y)
 367                      (expt x y)))
 368           (call    (lambda (p x y)
 369                      (p x y))))
 370       (catch 'foo
 371         (lambda ()
 372           (call-with-vm (lambda () (throw 'foo))))
 373         (lambda (key)
 374           (eq? key 'foo))))))
 375
 376 ;; These tests from Oleg Kiselyov's delim-control-n.scm, available at
 377 ;; http://okmij.org/ftp/Scheme/delim-control-n.scm.  Public domain.
 378 ;;
 379 (with-test-prefix "shift and reset"
 380   (pass-if (equal?
 381             117
 382             (+ 10 (reset (+ 2 (shift k (+ 100 (k (k 3)))))))))
 383
 384   (pass-if (equal?
 385             60
 386             (* 10 (reset (* 2 (shift g (* 5 (shift f (+ (f 1) 1)))))))))
 387
 388   (pass-if (equal?
 389             121
 390             (let ((f (lambda (x) (shift k (k (k x))))))
 391               (+ 1 (reset (+ 10 (f 100)))))))
 392
 393   (pass-if (equal?
 394             'a
 395             (car (reset
 396                   (let ((x (shift f
 397                                   (shift f1 (f1 (cons 'a (f '())))))))
 398                     (shift g x))))))
 399
 400   ;; Example by Olivier Danvy
 401   (pass-if (equal?
 402             '(1 2 3 4 5)
 403             (let ()
 404               (define (traverse xs)
 405                 (define (visit xs)
 406                   (if (null? xs)
 407                       '()
 408                       (visit (shift*
 409                               (lambda (k)
 410                                 (cons (car xs) (k (cdr xs))))))))
 411                 (reset* (lambda () (visit xs))))
 412               (traverse '(1 2 3 4 5))))))