1: ;;
    2: ;; test error handlers
    3: ;;
    4: 
    5: ;;  $Id: error.scm,v 1.13 2007/01/13 00:39:38 shirok Exp $
    6: 
    7: (use gauche.test)
    8: (test-start "error and exception handlers")
    9: 
   10: ;; NB: this test is run just after the primitive syntax test,
   11: ;; and before tests of many standard features.  So we test
   12: ;; the minimal features here.  The full test for the exception
   13: ;; handling system is done in exception.scm.
   14: 
   15: ;;----------------------------------------------------------------
   16: (test-section "with-error-handler")
   17: 
   18: (prim-test "basic" '(1 . 2)
   19:       (lambda ()
   20:         (cons 1 (with-error-handler (lambda (e) 2)
   21:                                     (lambda () (car 2))))))
   22: (prim-test "basic" '(1 2 3)
   23:       (lambda ()
   24:         (list (with-error-handler (lambda (e) 1)
   25:                                   (lambda () (car 2)))
   26:               (with-error-handler (lambda (e) -1)
   27:                                   (lambda () 2))
   28:               (with-error-handler (lambda (e) 3)
   29:                                   (lambda () (car 3))))))
   30: 
   31: (prim-test "with let" 1
   32:       (lambda ()
   33:         (let ((x 1))
   34:           (with-error-handler (lambda (e) x)
   35:                               (lambda () (car 0))))))
   36: 
   37: (prim-test "with let" 1
   38:       (lambda ()
   39:         (let ((x 1))
   40:           (with-error-handler (lambda (e) x)
   41:                               (lambda ()
   42:                                 (let ((x 2))
   43:                                   (car x)))))))
   44: 
   45: (prim-test "cascade" 3
   46:       (lambda ()
   47:         (with-error-handler
   48:          (lambda (e) 3)
   49:          (lambda ()
   50:            (with-error-handler
   51:             (lambda (e) (car 0))
   52:             (lambda ()
   53:               (car 4)))))))
   54: 
   55: (prim-test "over c stack" '(1 . 2)
   56:       (lambda ()
   57:         (cons 1
   58:               (with-error-handler
   59:                (lambda (e) 2)
   60:                (lambda ()
   61:                  (sort '(1 8 3 7 4)
   62:                        (lambda (a b) (car a))))))))
   63: 
   64: (prim-test "with dynamic wind" '(a b c)
   65:       (lambda ()
   66:         (let ((x '()))
   67:           (with-error-handler
   68:            (lambda (e) (set! x (cons 'b x)))
   69:            (lambda ()
   70:              (dynamic-wind
   71:               (lambda () (set! x (cons 'c x)))
   72:               (lambda () (car 3))
   73:               (lambda () (set! x (cons 'a x))))))
   74:           x)))
   75: 
   76: (prim-test "with dynamic wind" '(a b e c d f)
   77:       (lambda ()
   78:         (let ((x '()))
   79:           (dynamic-wind
   80:            (lambda () (push! x 'a))
   81:            (lambda ()
   82:              (with-error-handler
   83:               (lambda (e) (push! x 'e))
   84:               (lambda ()
   85:                 (dynamic-wind
   86:                  (lambda () (push! x 'b))
   87:                  (lambda () (car 3))
   88:                  (lambda () (push! x 'c)))))
   89:              (push! x 'd))
   90:            (lambda () (push! x 'f)))
   91:           (reverse x))))
   92: 
   93: (prim-test "repeat" 10
   94:       (lambda ()
   95:         (let loop ((i 0))
   96:           (if (< i 10)
   97:               (begin (with-error-handler
   98:                       (lambda (e) i)
   99:                       (lambda () (car i)))
  100:                      (loop (+ i 1)))
  101:               i))))
  102: 
  103: ;;----------------------------------------------------------------
  104: (test-section "cascading errors")
  105: 
  106: ;; tests various interactions with with-error-handler and dynamic-wind
  107: ;; when an error is raised from error handler.
  108: 
  109: (prim-test "cascading error" '(a b c e d)
  110:       (lambda ()
  111:         (let ((x '()))
  112:           (with-error-handler
  113:            (lambda (e) (push! x 'e))
  114:            (lambda ()
  115:              (dynamic-wind
  116:               (lambda () (push! x 'a))
  117:               (lambda ()
  118:                 (with-error-handler
  119:                  (lambda (e) (push! x 'c) (car 9))
  120:                  (lambda ()
  121:                    (push! x 'b)
  122:                    (car 3)
  123:                    (push! x 'z))))
  124:               (lambda () (push! x 'd)))))
  125:           (reverse x))))
  126: 
  127: (prim-test "cascading error 2" '(a b c d e f g)
  128:       (lambda ()
  129:         (let ((x '()))
  130:           (dynamic-wind
  131:            (lambda () (push! x 'a))
  132:            (lambda ()
  133:              (with-error-handler
  134:               (lambda (e) (push! x 'e))
  135:               (lambda ()
  136:                 (dynamic-wind
  137:                  (lambda () (push! x 'b))
  138:                  (lambda ()
  139:                    (with-error-handler
  140:                     (lambda (e) (push! x 'd) (raise e))
  141:                     (lambda ()  (push! x 'c) (car 3) (push! x 'z))))
  142:                  (lambda () (push! x 'f))))))
  143:            (lambda () (push! x 'g)))
  144:           (reverse x))))
  145: 
  146: (prim-test "cascading error 3" '(a b c d f g)
  147:       (lambda ()
  148:         (let ((x '()))
  149:           (dynamic-wind
  150:            (lambda () (push! x 'a))
  151:            (lambda ()
  152:              (with-error-handler
  153:               (lambda (e) (push! x e))
  154:               (lambda ()
  155:                 (dynamic-wind
  156:                  (lambda () (push! x 'b))
  157:                  (lambda ()
  158:                    (with-error-handler
  159:                     (lambda (e) (push! x 'd))
  160:                     (lambda ()  (push! x 'c) (car 3) (push! x 'z))))
  161:                  (lambda () (push! x 'f))))))
  162:            (lambda () (push! x 'g)))
  163:           (reverse x))))
  164: 
  165: (prim-test "cascading error 4" '(a b c d e f g h i j)
  166:       (lambda ()
  167:         (let ((x '()))
  168:           (dynamic-wind
  169:            (lambda () (push! x 'a))
  170:            (lambda ()
  171:              (with-error-handler
  172:               (lambda (e) (push! x 'g))
  173:               (lambda ()
  174:                 (dynamic-wind
  175:                  (lambda () (push! x 'b))
  176:                  (lambda ()
  177:                    (with-error-handler
  178:                     (lambda (e) (push! x 'f) (raise e))
  179:                     (lambda ()
  180:                       (dynamic-wind
  181:                        (lambda () (push! x 'c))
  182:                        (lambda ()
  183:                          (with-error-handler
  184:                           (lambda (e) (push! x 'e) (raise e))
  185:                           (lambda () (push! x 'd) (car 3) (push! x 'z))))
  186:                        (lambda () (push! x 'h))))))
  187:                  (lambda () (push! x 'i))))))
  188:            (lambda () (push! x 'j)))
  189:           (reverse x))))
  190: 
  191: (prim-test "cascading error 5" '(a b c d e f g)
  192:       (lambda ()
  193:         (let ((x '()))
  194:           (dynamic-wind
  195:            (lambda () (push! x 'a))
  196:            (lambda ()
  197:              (with-error-handler
  198:               (lambda (e) (push! x 'e))
  199:               (lambda ()
  200:                 (with-error-handler
  201:                  (lambda (e) (push! x 'd) (raise e))
  202:                  (lambda ()
  203:                    (dynamic-wind
  204:                     (lambda () (push! x 'b))
  205:                     (lambda () (push! x 'c) (car 3) (push! x 'z))
  206:                     (lambda () (push! x 'f))))))))
  207:            (lambda () (push! x 'g)))
  208:           (reverse x))))
  209: 
  210: (prim-test "cascading error 6" '(a b c d e f g)
  211:       (lambda ()
  212:         (let ((x '()))
  213:           (with-error-handler
  214:            (lambda (e) (push! x 'e))
  215:            (lambda () 
  216:              (dynamic-wind
  217:               (lambda () (push! x 'a))
  218:               (lambda ()
  219:                 (dynamic-wind
  220:                  (lambda () (push! x 'b))
  221:                  (lambda ()
  222:                    (with-error-handler
  223:                     (lambda (e) (push! x 'd) (raise e))
  224:                     (lambda ()  (push! x 'c) (open-input-file 3) (push! x 'z))))
  225:                  (lambda () (push! x 'f))))
  226:               (lambda () (push! x 'g)))))
  227:           (reverse x))))
  228: 
  229: ;;----------------------------------------------------------------
  230: (test-section "error in before/after thunk")
  231: 
  232: (prim-test "error in before thunk" '(a c)
  233:       (lambda ()
  234:         (let ((x '()))
  235:           (with-error-handler
  236:            (lambda (e) (push! x 'c))
  237:            (lambda ()
  238:              (dynamic-wind
  239:               (lambda () (push! x 'a) (car 3) (push! x 'z))
  240:               (lambda () (push! x 'b))
  241:               (lambda () (push! x 'c)))))
  242:           (reverse x))))
  243: 
  244: (prim-test "error in after thunk" '(a b c d)
  245:       (lambda ()
  246:         (let ((x '()))
  247:           (with-error-handler
  248:            (lambda (e) (push! x 'd))
  249:            (lambda ()
  250:              (dynamic-wind
  251:               (lambda () (push! x 'a))
  252:               (lambda () (push! x 'b))
  253:               (lambda () (push! x 'c) (car 3) (push! x 'z)))))
  254:           (reverse x))))
  255: 
  256: (prim-test "error in before thunk (nested)" '(a b c d)
  257:       (lambda ()
  258:         (let ((x '()))
  259:           (dynamic-wind
  260:            (lambda () (push! x 'a))
  261:            (lambda ()
  262:              (with-error-handler
  263:               (lambda (e) (push! x 'c))
  264:               (lambda ()
  265:                 (dynamic-wind
  266:                  (lambda () (push! x 'b) (car 3) (push! x 'z))
  267:                  (lambda () (push! x 'y))
  268:                  (lambda () (push! x 'x))))))
  269:            (lambda () (push! x 'd)))
  270:           (reverse x))))
  271: 
  272: (prim-test "error in after thunk (nested)" '(a b c d e f)
  273:       (lambda ()
  274:         (let ((x '()))
  275:           (dynamic-wind
  276:            (lambda () (push! x 'a))
  277:            (lambda ()
  278:              (with-error-handler
  279:               (lambda (e) (push! x 'e))
  280:               (lambda ()
  281:                 (dynamic-wind
  282:                  (lambda () (push! x 'b))
  283:                  (lambda () (push! x 'c))
  284:                  (lambda () (push! x 'd) (car 3) (push! x 'z))))))
  285:            (lambda () (push! x 'f)))
  286:           (reverse x))))
  287: 
  288: (prim-test "error in before thunk (cascaded)" '(a b c d e)
  289:       (lambda ()
  290:         (let ((x '()))
  291:           (with-error-handler
  292:            (lambda (e) (push! x 'd))
  293:            (lambda ()
  294:              (dynamic-wind
  295:               (lambda () (push! x 'a))
  296:               (lambda ()
  297:                 (with-error-handler
  298:                  (lambda (e) (push! x 'c) (raise e))
  299:                  (lambda ()
  300:                    (dynamic-wind
  301:                     (lambda () (push! x 'b) (car 3) (push! x 'z))
  302:                     (lambda () (push! x 'y))
  303:                     (lambda () (push! x 'x))))))
  304:               (lambda () (push! x 'e)))))
  305:           (reverse x))))
  306: 
  307: (prim-test "error in after thunk (cascaded)" '(a b c d e f g)
  308:       (lambda ()
  309:         (let ((x '()))
  310:           (with-error-handler
  311:            (lambda (e) (push! x 'f))
  312:            (lambda ()
  313:              (dynamic-wind
  314:               (lambda () (push! x 'a))
  315:               (lambda ()
  316:                 (with-error-handler
  317:                  (lambda (e) (push! x 'e) (raise e))
  318:                  (lambda ()
  319:                    (dynamic-wind
  320:                     (lambda () (push! x 'b))
  321:                     (lambda () (push! x 'c))
  322:                     (lambda () (push! x 'd) (car 3) (push! x 'z))))))
  323:               (lambda () (push! x 'g)))))
  324:           (reverse x))))
  325: 
  326: ;;----------------------------------------------------------------
  327: (test-section "restart and error handler")
  328: 
  329: (prim-test "restart" '(a b x b x)
  330:       (lambda ()
  331:         (let ((x '())
  332:               (c #f))
  333:           (with-error-handler
  334:            (lambda (e) (push! x 'x))
  335:            (lambda ()
  336:              (push! x 'a)
  337:              (set! c (call/cc identity))
  338:              (push! x 'b)
  339:              (car 3)
  340:              (push! x 'z)))
  341:           (when c (c #f))
  342:           (reverse x))))
  343: 
  344: (prim-test "restart & dynamic-wind" '(a b c x e f z a b x e f z)
  345:       (lambda ()
  346:         (let ((x '())
  347:               (c #f))
  348:           (dynamic-wind
  349:            (lambda () (push! x 'a))
  350:            (lambda ()
  351:              (with-error-handler
  352:               (lambda (e) (push! x 'x))
  353:               (lambda ()
  354:                 (dynamic-wind
  355:                  (lambda () (push! x 'b))
  356:                  (lambda ()
  357:                    (push! x 'c)
  358:                    (set! c (call/cc (lambda (k) k)))
  359:                    (car 3)
  360:                    (push! x 'd))
  361:                  (lambda () (push! x 'e))))))
  362:            (lambda () (push! x 'f)))
  363:           (push! x 'z)
  364:           (when c (c #f))
  365:           (reverse x))))
  366: 
  367: ;;----------------------------------------------------------------
  368: (test-section "with-exception-handler")
  369: 
  370: (prim-test "simple" '(a b c)
  371:       (lambda ()
  372:         (let ((x '()))
  373:           (with-exception-handler
  374:            (lambda (e) (push! x e))
  375:            (lambda ()
  376:              (push! x 'a)
  377:              (raise 'b)
  378:              (push! x 'c)))
  379:           (reverse x))))
  380: 
  381: (prim-test "w/dynamic-wind" '(a b c d e f g)
  382:       (lambda ()
  383:         (let ((x '()))
  384:           (dynamic-wind
  385:            (lambda () (push! x 'a))
  386:            (lambda ()
  387:              (with-exception-handler
  388:               (lambda (e) (push! x e))
  389:               (lambda ()
  390:                 (dynamic-wind
  391:                  (lambda () (push! x 'b))
  392:                  (lambda () (push! x 'c) (raise 'd) (push! x 'e))
  393:                  (lambda () (push! x 'f))))))
  394:            (lambda () (push! x 'g)))
  395:           (reverse x))))
  396: 
  397: (prim-test "manual restart (simple)" '(a b c)
  398:       (lambda ()
  399:         (let ((x '()))
  400:           (push! x
  401:                  (call/cc
  402:                   (lambda (cont)
  403:                     (with-exception-handler
  404:                      (lambda (e)
  405:                        (push! x 'b)
  406:                        (cont 'c))
  407:                      (lambda () (push! x 'a) (car 3))))))
  408:           (reverse x))))
  409: 
  410: (prim-test "manual restart (w/ dynamic-wind)" '(a b c e d)
  411:       (lambda ()
  412:         (let ((x '()))
  413:           (push! x
  414:                  (call/cc
  415:                   (lambda (cont)
  416:                     (dynamic-wind
  417:                      (lambda () (push! x 'a))
  418:                      (lambda ()
  419:                        (with-exception-handler
  420:                         (lambda (e)
  421:                           (push! x 'c)
  422:                           (cont 'd))
  423:                         (lambda () (push! x 'b) (car 3))))
  424:                      (lambda () (push! x 'e))))))
  425:           (reverse x))))
  426: 
  427: (prim-test "noncontinuable error" '(a b c g y)
  428:       (lambda ()
  429:         (let ((x '()))
  430:           (with-error-handler
  431:            (lambda (e) (push! x 'g))
  432:            (lambda ()
  433:              (with-exception-handler
  434:               (lambda (e) (push! x 'c))
  435:               (lambda ()
  436:                 (dynamic-wind
  437:                  (lambda () (push! x 'a))
  438:                  (lambda () (push! x 'b) (car 3) (push! x 'z))
  439:                  (lambda () (push! x 'y)))))))
  440:           (reverse x))))
  441: 
  442: ;;----------------------------------------------------------------
  443: (test-section "nesting exception/error handlers")
  444: 
  445: (prim-test "propagating continuable exception" '(a b c)
  446:       (lambda ()
  447:         (let ((x '()))
  448:           (with-exception-handler
  449:            (lambda (e) (push! x e))
  450:            (lambda ()
  451:              (with-error-handler
  452:               (lambda (e) (push! x 'z))
  453:               (lambda ()
  454:                 (push! x 'a)
  455:                 (raise 'b)
  456:                 (push! x 'c)))))
  457:           (reverse x))))
  458: 
  459: (prim-test "propagating continuable exception" '(a b c d e f g h)
  460:       (lambda ()
  461:         (let ((x '()))
  462:           (with-exception-handler
  463:            (lambda (e) (push! x e))
  464:            (lambda ()
  465:              (dynamic-wind
  466:               (lambda () (push! x 'a))
  467:               (lambda ()
  468:                 (with-error-handler
  469:                  (lambda (e) (push! x 'z))
  470:                  (lambda ()
  471:                    (dynamic-wind
  472:                     (lambda () (push! x 'b))
  473:                     (lambda ()
  474:                       (with-error-handler
  475:                        (lambda (e) (push! x 'f))
  476:                        (lambda ()
  477:                          (push! x 'c)
  478:                          (raise 'd)
  479:                          (push! x 'e)
  480:                          (car 3)
  481:                          (push! x 'z))))
  482:                     (lambda () (push! x 'g))))))
  483:               (lambda () (push! x 'h)))))
  484:           (reverse x))))
  485: 
  486: ;;----------------------------------------------------------------
  487: (test-section "interaction with empty environment frame")
  488: 
  489: (prim-test "empty do" 'ok
  490:       (lambda ()
  491:         (let ((x 0))
  492:           (do () ((> x 0) 'ok)
  493:             (with-error-handler
  494:                 (lambda (e) (inc! x))
  495:               (lambda () (car x)))))))
  496: 
  497: 
  498: (prim-test "empty let" 'ok
  499:       (lambda ()
  500:         (let ((x 0))
  501:           (let loop ()
  502:             (with-error-handler
  503:                 (lambda (e) (inc! x) (loop))
  504:               (lambda ()
  505:                 (if (> x 2)
  506:                     'ok
  507:                     (car x))))))))
  508: 
  509: ;;----------------------------------------------------------------
  510: (test-section "error and errorf procedures")
  511: 
  512: (prim-test "error (<error>)" "Message 1 \"2\" (:a . #\\4)"
  513:            (lambda ()
  514:              (with-error-handler
  515:                  (lambda (e)
  516:                    (and (is-a? e <error>) (slot-ref e 'message)))
  517:                (lambda ()
  518:                  (error "Message" 1 "2" (cons :a #\4))))))
  519: 
  520: (prim-test "errorf (<error>)" "Message 1 and 2 or 3 and 4"
  521:            (lambda ()
  522:              (with-error-handler
  523:                  (lambda (e)
  524:                    (and (is-a? e <error>) (slot-ref e 'message)))
  525:                (lambda ()
  526:                  (errorf "Message ~a and ~a or ~a and ~a" 1 2 3 4)))))
  527: 
  528: (prim-test "error (<system-error>)" '("Wow: \"bang!\" 4" 111)
  529:            (lambda ()
  530:              (with-error-handler
  531:                  (lambda (e)
  532:                    (and (is-a? e <system-error>)
  533:                         (list (slot-ref e 'message)
  534:                               (slot-ref e 'errno))))
  535:                (lambda ()
  536:                  (error <system-error> :errno 111 "Wow:" "bang!" 4)))))
  537: 
  538: (prim-test "errorf (<system-error>)" '("Wow: \"bang!\" 4" 111)
  539:            (lambda ()
  540:              (with-error-handler
  541:                  (lambda (e)
  542:                    (and (is-a? e <system-error>)