guile18/test-suite/tests/exceptions.test

   1 ;;;; exceptions.test --- tests for Guile's exception handling  -*- scheme -*-
   2 ;;;; Copyright (C) 2001, 2003, 2004, 2006 Free Software Foundation, Inc.
   3 ;;;;
   4 ;;;; This library is free software; you can redistribute it and/or
   5 ;;;; modify it under the terms of the GNU Lesser General Public
   6 ;;;; License as published by the Free Software Foundation; either
   7 ;;;; version 2.1 of the License, or (at your option) any later version.
   8 ;;;;
   9 ;;;; This library is distributed in the hope that it will be useful,
  10 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;;;; Lesser General Public License for more details.
  13 ;;;;
  14 ;;;; You should have received a copy of the GNU Lesser General Public
  15 ;;;; License along with this library; if not, write to the Free Software
  16 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17
  18
  19 (use-modules (test-suite lib))
  20
  21 (define-macro (throw-test title result . exprs)
  22   `(pass-if ,title
  23      (equal? ,result
  24              (letrec ((stack '())
  25                       (push (lambda (val)
  26                               (set! stack (cons val stack)))))
  27                (begin ,@exprs)
  28                ;;(display ,title)
  29                ;;(display ": ")
  30                ;;(write (reverse stack))
  31                ;;(newline)
  32                (reverse stack)))))
  33
  34 (with-test-prefix "throw/catch"
  35
  36   (with-test-prefix "wrong type argument"
  37
  38     (pass-if-exception "(throw 1)"
  39       exception:wrong-type-arg
  40       (throw 1)))
  41
  42   (with-test-prefix "wrong number of arguments"
  43
  44     (pass-if-exception "(throw)"
  45       exception:wrong-num-args
  46       (throw))
  47
  48     (pass-if-exception "throw 1 / catch 0"
  49       exception:wrong-num-args
  50       (catch 'a
  51         (lambda () (throw 'a))
  52         (lambda () #f)))
  53
  54     (pass-if-exception "throw 2 / catch 1"
  55       exception:wrong-num-args
  56       (catch 'a
  57         (lambda () (throw 'a 2))
  58         (lambda (x) #f)))
  59
  60     (pass-if-exception "throw 1 / catch 2"
  61       exception:wrong-num-args
  62       (catch 'a
  63         (lambda () (throw 'a))
  64         (lambda (x y) #f)))
  65
  66     (pass-if-exception "throw 3 / catch 2"
  67       exception:wrong-num-args
  68       (catch 'a
  69         (lambda () (throw 'a 2 3))
  70         (lambda (y x) #f)))
  71
  72     (pass-if-exception "throw 1 / catch 2+"
  73       exception:wrong-num-args
  74       (catch 'a
  75         (lambda () (throw 'a))
  76         (lambda (x y . rest) #f))))
  77
  78   (with-test-prefix "with lazy handler"
  79
  80     (pass-if "lazy fluid state"
  81       (equal? '(inner outer arg)
  82        (let ((fluid-parm (make-fluid))
  83              (inner-val #f))
  84          (fluid-set! fluid-parm 'outer)
  85          (catch 'misc-exc
  86            (lambda ()
  87              (with-fluids ((fluid-parm 'inner))
  88                (throw 'misc-exc 'arg)))
  89            (lambda (key . args)
  90              (list inner-val
  91                    (fluid-ref fluid-parm)
  92                    (car args)))
  93            (lambda (key . args)
  94              (set! inner-val (fluid-ref fluid-parm))))))))
  95
  96   (throw-test "normal catch"
  97               '(1 2)
  98               (catch 'a
  99                      (lambda ()
 100                        (push 1)
 101                        (throw 'a))
 102                      (lambda (key . args)
 103                        (push 2))))
 104
 105   (throw-test "catch and lazy catch"
 106               '(1 2 3 4)
 107               (catch 'a
 108                      (lambda ()
 109                        (push 1)
 110                        (lazy-catch 'a
 111                                    (lambda ()
 112                                      (push 2)
 113                                      (throw 'a))
 114                                    (lambda (key . args)
 115                                      (push 3))))
 116                      (lambda (key . args)
 117                        (push 4))))
 118
 119   (throw-test "catch with rethrowing lazy catch handler"
 120               '(1 2 3 4)
 121               (catch 'a
 122                      (lambda ()
 123                        (push 1)
 124                        (lazy-catch 'a
 125                                    (lambda ()
 126                                      (push 2)
 127                                      (throw 'a))
 128                                    (lambda (key . args)
 129                                      (push 3)
 130                                      (apply throw key args))))
 131                      (lambda (key . args)
 132                        (push 4))))
 133
 134   (throw-test "catch with pre-unwind handler"
 135               '(1 3 2)
 136               (catch 'a
 137                      (lambda ()
 138                        (push 1)
 139                        (throw 'a))
 140                      (lambda (key . args)
 141                        (push 2))
 142                      (lambda (key . args)
 143                        (push 3))))
 144
 145   (throw-test "catch with rethrowing pre-unwind handler"
 146               '(1 3 2)
 147               (catch 'a
 148                      (lambda ()
 149                        (push 1)
 150                        (throw 'a))
 151                      (lambda (key . args)
 152                        (push 2))
 153                      (lambda (key . args)
 154                        (push 3)
 155                        (apply throw key args))))
 156
 157   (throw-test "catch with throw handler"
 158               '(1 2 3 4)
 159               (catch 'a
 160                      (lambda ()
 161                        (push 1)
 162                        (with-throw-handler 'a
 163                                            (lambda ()
 164                                              (push 2)
 165                                              (throw 'a))
 166                                            (lambda (key . args)
 167                                              (push 3))))
 168                      (lambda (key . args)
 169                        (push 4))))
 170
 171   (throw-test "catch with rethrowing throw handler"
 172               '(1 2 3 4)
 173               (catch 'a
 174                      (lambda ()
 175                        (push 1)
 176                        (with-throw-handler 'a
 177                                            (lambda ()
 178                                              (push 2)
 179                                              (throw 'a))
 180                                            (lambda (key . args)
 181                                              (push 3)
 182                                              (apply throw key args))))
 183                      (lambda (key . args)
 184                        (push 4))))
 185
 186   (throw-test "effect of lazy-catch unwinding on throw to another key"
 187               '(1 2 3 5 7)
 188               (catch 'a
 189                      (lambda ()
 190                        (push 1)
 191                        (lazy-catch 'b
 192                                    (lambda ()
 193                                      (push 2)
 194                                      (catch 'a
 195                                             (lambda ()
 196                                               (push 3)
 197                                               (throw 'b))
 198                                             (lambda (key . args)
 199                                               (push 4))))
 200                                    (lambda (key . args)
 201                                      (push 5)
 202                                      (throw 'a)))
 203                        (push 6))
 204                      (lambda (key . args)
 205                        (push 7))))
 206
 207   (throw-test "effect of with-throw-handler not-unwinding on throw to another key"
 208               '(1 2 3 5 4 6)
 209               (catch 'a
 210                      (lambda ()
 211                        (push 1)
 212                        (with-throw-handler 'b
 213                                    (lambda ()
 214                                      (push 2)
 215                                      (catch 'a
 216                                             (lambda ()
 217                                               (push 3)
 218                                               (throw 'b))
 219                                             (lambda (key . args)
 220                                               (push 4))))
 221                                    (lambda (key . args)
 222                                      (push 5)
 223                                      (throw 'a)))
 224                        (push 6))
 225                      (lambda (key . args)
 226                        (push 7))))
 227
 228   (throw-test "lazy-catch chaining"
 229               '(1 2 3 4 6 8)
 230               (catch 'a
 231                 (lambda ()
 232                   (push 1)
 233                   (lazy-catch 'a
 234                     (lambda ()
 235                       (push 2)
 236                       (lazy-catch 'a
 237                         (lambda ()
 238                           (push 3)
 239                           (throw 'a))
 240                         (lambda (key . args)
 241                           (push 4)))
 242                       (push 5))
 243                     (lambda (key . args)
 244                       (push 6)))
 245                   (push 7))
 246                 (lambda (key . args)
 247                   (push 8))))
 248
 249   (throw-test "with-throw-handler chaining"
 250               '(1 2 3 4 6 8)
 251               (catch 'a
 252                 (lambda ()
 253                   (push 1)
 254                   (with-throw-handler 'a
 255                     (lambda ()
 256                       (push 2)
 257                       (with-throw-handler 'a
 258                         (lambda ()
 259                           (push 3)
 260                           (throw 'a))
 261                         (lambda (key . args)
 262                           (push 4)))
 263                       (push 5))
 264                     (lambda (key . args)
 265                       (push 6)))
 266                   (push 7))
 267                 (lambda (key . args)
 268                   (push 8))))
 269
 270   (throw-test "with-throw-handler inside lazy-catch"
 271               '(1 2 3 4 6 8)
 272               (catch 'a
 273                 (lambda ()
 274                   (push 1)
 275                   (lazy-catch 'a
 276                     (lambda ()
 277                       (push 2)
 278                       (with-throw-handler 'a
 279                         (lambda ()
 280                           (push 3)
 281                           (throw 'a))
 282                         (lambda (key . args)
 283                           (push 4)))
 284                       (push 5))
 285                     (lambda (key . args)
 286                       (push 6)))
 287                   (push 7))
 288                 (lambda (key . args)
 289                   (push 8))))
 290
 291   (throw-test "lazy-catch inside with-throw-handler"
 292               '(1 2 3 4 6 8)
 293               (catch 'a
 294                 (lambda ()
 295                   (push 1)
 296                   (with-throw-handler 'a
 297                     (lambda ()
 298                       (push 2)
 299                       (lazy-catch 'a
 300                         (lambda ()
 301                           (push 3)
 302                           (throw 'a))
 303                         (lambda (key . args)
 304                           (push 4)))
 305                       (push 5))
 306                     (lambda (key . args)
 307                       (push 6)))
 308                   (push 7))
 309                 (lambda (key . args)
 310                   (push 8))))
 311
 312   (throw-test "throw handlers throwing to each other recursively"
 313               '(1 2 3 4 8 6 10 12)
 314               (catch #t
 315                 (lambda ()
 316                   (push 1)
 317                   (with-throw-handler 'a
 318                     (lambda ()
 319                       (push 2)
 320                       (with-throw-handler 'b
 321                         (lambda ()
 322                           (push 3)
 323                           (with-throw-handler 'c
 324                             (lambda ()
 325                               (push 4)
 326                               (throw 'b)
 327                               (push 5))
 328                             (lambda (key . args)
 329                               (push 6)
 330                               (throw 'a)))
 331                           (push 7))
 332                         (lambda (key . args)
 333                           (push 8)
 334                           (throw 'c)))
 335                       (push 9))
 336                     (lambda (key . args)
 337                       (push 10)
 338                       (throw 'b)))
 339                   (push 11))
 340                 (lambda (key . args)
 341                   (push 12))))
 342
 343   (throw-test "repeat of previous test but with lazy-catch"
 344               '(1 2 3 4 8 12)
 345               (catch #t
 346                 (lambda ()
 347                   (push 1)
 348                   (lazy-catch 'a
 349                     (lambda ()
 350                       (push 2)
 351                       (lazy-catch 'b
 352                         (lambda ()
 353                           (push 3)
 354                           (lazy-catch 'c
 355                             (lambda ()
 356                               (push 4)
 357                               (throw 'b)
 358                               (push 5))
 359                             (lambda (key . args)
 360                               (push 6)
 361                               (throw 'a)))
 362                           (push 7))
 363                         (lambda (key . args)
 364                           (push 8)
 365                           (throw 'c)))
 366                       (push 9))
 367                     (lambda (key . args)
 368                       (push 10)
 369                       (throw 'b)))
 370                   (push 11))
 371                 (lambda (key . args)
 372                   (push 12))))
 373
 374   (throw-test "throw handler throwing to lexically inside catch"
 375               '(1 2 7 5 4 6 9)
 376               (with-throw-handler 'a
 377                                   (lambda ()
 378                                     (push 1)
 379                                     (catch 'b
 380                                            (lambda ()
 381                                              (push 2)
 382                                              (throw 'a)
 383                                              (push 3))
 384                                            (lambda (key . args)
 385                                              (push 4))
 386                                            (lambda (key . args)
 387                                              (push 5)))
 388                                     (push 6))
 389                                   (lambda (key . args)
 390                                     (push 7)
 391                                     (throw 'b)
 392                                     (push 8)))
 393               (push 9))
 394
 395   (throw-test "reuse of same throw handler after lexically inside catch"
 396               '(0 1 2 7 5 4 6 7 10)
 397               (catch 'b
 398                 (lambda ()
 399                   (push 0)
 400                   (with-throw-handler 'a
 401                     (lambda ()
 402                       (push 1)
 403                       (catch 'b
 404                         (lambda ()
 405                           (push 2)
 406                           (throw 'a)
 407                           (push 3))
 408                         (lambda (key . args)
 409                           (push 4))
 410                         (lambda (key . args)
 411                           (push 5)))
 412                       (push 6)
 413                       (throw 'a))
 414                     (lambda (key . args)
 415                       (push 7)
 416                       (throw 'b)
 417                       (push 8)))
 418                   (push 9))
 419                 (lambda (key . args)
 420                   (push 10))))
 421
 422   (throw-test "again but with two chained throw handlers"
 423               '(0 1 11 2 13 7 5 4 12 13 7 10)
 424               (catch 'b
 425                 (lambda ()
 426                   (push 0)
 427                   (with-throw-handler 'a
 428                     (lambda ()
 429                       (push 1)
 430                       (with-throw-handler 'a
 431                         (lambda ()
 432                           (push 11)
 433                           (catch 'b
 434                             (lambda ()
 435                               (push 2)
 436                               (throw 'a)
 437                               (push 3))
 438                             (lambda (key . args)
 439                               (push 4))
 440                             (lambda (key . args)
 441                               (push 5)))
 442                           (push 12)
 443                           (throw 'a))
 444                         (lambda (key . args)
 445                           (push 13)))
 446                       (push 6))
 447                     (lambda (key . args)
 448                       (push 7)
 449                       (throw 'b)))
 450                   (push 9))
 451                 (lambda (key . args)
 452                   (push 10))))
 453
 454   )
 455
 456 (with-test-prefix "false-if-exception"
 457
 458   (pass-if (false-if-exception #t))
 459   (pass-if (not (false-if-exception #f)))
 460   (pass-if (not (false-if-exception (error "xxx"))))
 461
 462   ;; Not yet working.
 463   ;;
 464   ;; (with-test-prefix "in empty environment"
 465   ;;   ;; an environment with no bindings at all
 466   ;;   (define empty-environment
 467   ;;     (make-module 1))
 468   ;;
 469   ;;   (pass-if "#t"
 470   ;;     (eval `(,false-if-exception #t)
 471   ;;        empty-environment))
 472   ;;   (pass-if "#f"
 473   ;;     (not (eval `(,false-if-exception #f)
 474   ;;             empty-environment)))
 475   ;;   (pass-if "exception"
 476   ;;     (not (eval `(,false-if-exception (,error "xxx"))
 477   ;;                empty-environment))))
 478   )