1;;;; exceptions.test --- tests for Guile's exception handling -*- scheme -*- 2;;;; Copyright (C) 2001, 2003, 2004, 2006, 2010 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 3 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(define-module (test-suite exceptions) 20 #:use-module (test-suite lib)) 21 22(define-syntax-parameter push 23 (lambda (stx) 24 (syntax-violation 'push "push used outside of throw-test" stx))) 25 26(define-syntax-rule (throw-test title result expr ...) 27 (pass-if-equal title result 28 (let ((stack '())) 29 (syntax-parameterize ((push (syntax-rules () 30 ((push val) 31 (set! stack (cons val stack)))))) 32 expr ... 33 ;;(format #t "~a: ~s~%" title (reverse stack)) 34 (reverse stack))))) 35 36(with-test-prefix "throw/catch" 37 38 (with-test-prefix "wrong type argument" 39 40 (pass-if-exception "(throw 1)" 41 exception:wrong-type-arg 42 (throw 1))) 43 44 (with-test-prefix "wrong number of arguments" 45 46 (pass-if-exception "(throw)" 47 exception:wrong-num-args 48 (throw)) 49 50 (pass-if-exception "throw 1 / catch 0" 51 exception:wrong-num-args 52 (catch 'a 53 (lambda () (throw 'a)) 54 (lambda () #f))) 55 56 (pass-if-exception "throw 2 / catch 1" 57 exception:wrong-num-args 58 (catch 'a 59 (lambda () (throw 'a 2)) 60 (lambda (x) #f))) 61 62 (pass-if-exception "throw 1 / catch 2" 63 exception:wrong-num-args 64 (catch 'a 65 (lambda () (throw 'a)) 66 (lambda (x y) #f))) 67 68 (pass-if-exception "throw 3 / catch 2" 69 exception:wrong-num-args 70 (catch 'a 71 (lambda () (throw 'a 2 3)) 72 (lambda (y x) #f))) 73 74 (pass-if-exception "throw 1 / catch 2+" 75 exception:wrong-num-args 76 (catch 'a 77 (lambda () (throw 'a)) 78 (lambda (x y . rest) #f)))) 79 80 (with-test-prefix "with pre-unwind handler" 81 82 (pass-if "pre-unwind fluid state" 83 (equal? '(inner outer arg) 84 (let ((fluid-parm (make-fluid)) 85 (inner-val #f)) 86 (fluid-set! fluid-parm 'outer) 87 (catch 'misc-exc 88 (lambda () 89 (with-fluids ((fluid-parm 'inner)) 90 (throw 'misc-exc 'arg))) 91 (lambda (key . args) 92 (list inner-val 93 (fluid-ref fluid-parm) 94 (car args))) 95 (lambda (key . args) 96 (set! inner-val (fluid-ref fluid-parm)))))))) 97 98 (throw-test "normal catch" 99 '(1 2) 100 (catch 'a 101 (lambda () 102 (push 1) 103 (throw 'a)) 104 (lambda (key . args) 105 (push 2)))) 106 107 (throw-test "catch and with-throw-handler" 108 '(1 2 3 4) 109 (catch 'a 110 (lambda () 111 (push 1) 112 (with-throw-handler 113 'a 114 (lambda () 115 (push 2) 116 (throw 'a)) 117 (lambda (key . args) 118 (push 3)))) 119 (lambda (key . args) 120 (push 4)))) 121 122 (throw-test "catch with rethrowing throw-handler" 123 '(1 2 3 4) 124 (catch 'a 125 (lambda () 126 (push 1) 127 (with-throw-handler 128 'a 129 (lambda () 130 (push 2) 131 (throw 'a)) 132 (lambda (key . args) 133 (push 3) 134 (apply throw key args)))) 135 (lambda (key . args) 136 (push 4)))) 137 138 (throw-test "catch with pre-unwind handler" 139 '(1 3 2) 140 (catch 'a 141 (lambda () 142 (push 1) 143 (throw 'a)) 144 (lambda (key . args) 145 (push 2)) 146 (lambda (key . args) 147 (push 3)))) 148 149 (throw-test "catch with rethrowing pre-unwind handler" 150 '(1 3 2) 151 (catch 'a 152 (lambda () 153 (push 1) 154 (throw 'a)) 155 (lambda (key . args) 156 (push 2)) 157 (lambda (key . args) 158 (push 3) 159 (apply throw key args)))) 160 161 (throw-test "catch with throw handler" 162 '(1 2 3 4) 163 (catch 'a 164 (lambda () 165 (push 1) 166 (with-throw-handler 'a 167 (lambda () 168 (push 2) 169 (throw 'a)) 170 (lambda (key . args) 171 (push 3)))) 172 (lambda (key . args) 173 (push 4)))) 174 175 (throw-test "catch with rethrowing throw handler" 176 '(1 2 3 4) 177 (catch 'a 178 (lambda () 179 (push 1) 180 (with-throw-handler 'a 181 (lambda () 182 (push 2) 183 (throw 'a)) 184 (lambda (key . args) 185 (push 3) 186 (apply throw key args)))) 187 (lambda (key . args) 188 (push 4)))) 189 190 (throw-test "effect of with-throw-handler not-unwinding on throw to another key" 191 '(1 2 3 5 4 6) 192 (catch 'a 193 (lambda () 194 (push 1) 195 (with-throw-handler 'b 196 (lambda () 197 (push 2) 198 (catch 'a 199 (lambda () 200 (push 3) 201 (throw 'b)) 202 (lambda (key . args) 203 (push 4)))) 204 (lambda (key . args) 205 (push 5) 206 (throw 'a))) 207 (push 6)) 208 (lambda (key . args) 209 (push 7)))) 210 211 (throw-test "with-throw-handler chaining" 212 '(1 2 3 4 6 8) 213 (catch 'a 214 (lambda () 215 (push 1) 216 (with-throw-handler 'a 217 (lambda () 218 (push 2) 219 (with-throw-handler 'a 220 (lambda () 221 (push 3) 222 (throw 'a)) 223 (lambda (key . args) 224 (push 4))) 225 (push 5)) 226 (lambda (key . args) 227 (push 6))) 228 (push 7)) 229 (lambda (key . args) 230 (push 8)))) 231 232 (throw-test "throw handlers throwing to each other recursively" 233 '(1 2 3 4 8 6 10 12) 234 (catch #t 235 (lambda () 236 (push 1) 237 (with-throw-handler 'a 238 (lambda () 239 (push 2) 240 (with-throw-handler 'b 241 (lambda () 242 (push 3) 243 (with-throw-handler 'c 244 (lambda () 245 (push 4) 246 (throw 'b) 247 (push 5)) 248 (lambda (key . args) 249 (push 6) 250 (throw 'a))) 251 (push 7)) 252 (lambda (key . args) 253 (push 8) 254 (throw 'c))) 255 (push 9)) 256 (lambda (key . args) 257 (push 10) 258 (throw 'b))) 259 (push 11)) 260 (lambda (key . args) 261 (push 12)))) 262 263 (throw-test "throw handler throwing to lexically inside catch" 264 '(1 2 7 5 4 6 9) 265 (with-throw-handler 'a 266 (lambda () 267 (push 1) 268 (catch 'b 269 (lambda () 270 (push 2) 271 (throw 'a) 272 (push 3)) 273 (lambda (key . args) 274 (push 4)) 275 (lambda (key . args) 276 (push 5))) 277 (push 6)) 278 (lambda (key . args) 279 (push 7) 280 (throw 'b) 281 (push 8))) 282 (push 9)) 283 284 (throw-test "reuse of same throw handler after lexically inside catch" 285 '(0 1 2 7 5 4 6 7 10) 286 (catch 'b 287 (lambda () 288 (push 0) 289 (with-throw-handler 'a 290 (lambda () 291 (push 1) 292 (catch 'b 293 (lambda () 294 (push 2) 295 (throw 'a) 296 (push 3)) 297 (lambda (key . args) 298 (push 4)) 299 (lambda (key . args) 300 (push 5))) 301 (push 6) 302 (throw 'a)) 303 (lambda (key . args) 304 (push 7) 305 (throw 'b) 306 (push 8))) 307 (push 9)) 308 (lambda (key . args) 309 (push 10)))) 310 311 (throw-test "again but with two chained throw handlers" 312 '(0 1 11 2 13 7 5 4 12 13 7 10) 313 (catch 'b 314 (lambda () 315 (push 0) 316 (with-throw-handler 'a 317 (lambda () 318 (push 1) 319 (with-throw-handler 'a 320 (lambda () 321 (push 11) 322 (catch 'b 323 (lambda () 324 (push 2) 325 (throw 'a) 326 (push 3)) 327 (lambda (key . args) 328 (push 4)) 329 (lambda (key . args) 330 (push 5))) 331 (push 12) 332 (throw 'a)) 333 (lambda (key . args) 334 (push 13))) 335 (push 6)) 336 (lambda (key . args) 337 (push 7) 338 (throw 'b))) 339 (push 9)) 340 (lambda (key . args) 341 (push 10)))) 342 343 ) 344 345(with-test-prefix "false-if-exception" 346 347 (pass-if (false-if-exception #t)) 348 (pass-if (not (false-if-exception #f))) 349 (pass-if (not (false-if-exception (error "xxx")))) 350 351 ;; Not yet working. 352 ;; 353 ;; (with-test-prefix "in empty environment" 354 ;; ;; an environment with no bindings at all 355 ;; (define empty-environment 356 ;; (make-module 1)) 357 ;; 358 ;; (pass-if "#t" 359 ;; (eval `(,false-if-exception #t) 360 ;; empty-environment)) 361 ;; (pass-if "#f" 362 ;; (not (eval `(,false-if-exception #f) 363 ;; empty-environment))) 364 ;; (pass-if "exception" 365 ;; (not (eval `(,false-if-exception (,error "xxx")) 366 ;; empty-environment)))) 367 ) 368 369(with-test-prefix "delimited exception handlers" 370 (define (catch* key thunk) 371 (let ((tag (make-prompt-tag))) 372 (call-with-prompt tag 373 (lambda () 374 (catch key 375 (lambda () 376 (abort-to-prompt tag) 377 (thunk)) 378 (lambda args args))) 379 (lambda (k) k)))) 380 (pass-if-equal '(foo) 381 (let ((thunk (catch* 'foo (lambda () (throw 'foo))))) 382 (thunk))) 383 (pass-if-equal '(foo) 384 (let* ((thunk1 (catch* 'foo (lambda () (throw 'foo)))) 385 (thunk2 (catch* 'bar (lambda () (thunk1))))) 386 (thunk1))) 387 (pass-if-equal '(foo) 388 (let* ((thunk1 (catch* 'foo (lambda () (throw 'foo)))) 389 (thunk2 (catch* 'bar (lambda () (thunk1))))) 390 (thunk2))) 391 (pass-if-equal '(bar) 392 (let* ((thunk1 (catch* 'foo (lambda () (throw 'bar)))) 393 (thunk2 (catch* 'bar (lambda () (thunk1))))) 394 (thunk2)))) 395