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