klisp

an open source interpreter for the Kernel Programming Language.
git clone http://git.hanabi.in/repos/klisp.git
Log | Files | Refs | README

error.k (2458B)

      1 ;; check.k & test-helpers.k should be loaded
      2 ;;
      3 ;; Tests of error handling applicatives.
      4 ;;
      5 
      6 ;; XXX error
      7 ;;
      8 ($check-error (error "test"))
      9 
     10 ;; XXX error-object? error-object-message error-object-irritants
     11 ;;
     12 ($let*
     13     ( (capture-error-object
     14        ($lambda (proc)
     15          (guard-dynamic-extent
     16           ()
     17           proc
     18           (list (list error-continuation
     19                       ($lambda (obj divert)
     20                         (apply divert obj)))))))
     21       (e1 (capture-error-object ($lambda () (error "a"))))
     22       (e2 (capture-error-object ($lambda () (error "b" 1 2 3))))
     23       (e3 (capture-error-object ($lambda () (error))))
     24       (e4 (capture-error-object ($lambda () (error 1)))))
     25 
     26   ($check-predicate (error-object? e1 e2 e3))
     27   ($check-not-predicate (error-object? ""))
     28   ($check-not-predicate (error-object? #f))
     29   ($check-not-predicate (error-object? ()))
     30   ($check-not-predicate (error-object? 0))
     31 
     32   ($check equal? (error-object-message e1) "a")
     33   ($check equal? (error-object-message e2) "b")
     34 
     35   ($check-error (error-object-message))
     36   ($check-error (error-object-message e1 e2))
     37   ($check-error (error-object-message "not an error object"))
     38 
     39   ($check equal? (error-object-irritants e1) ())
     40   ($check equal? (error-object-irritants e2) (list 1 2 3))
     41   ($check equal? (error-object-irritants e3) ())
     42   ;; error now uses the standard binding constructs from kghelper
     43   ;; for now they don't encapsulate any data in the error, but
     44   ;; they will in the future
     45   ;;  ($check equal? (error-object-irritants e4) (list 1))
     46 
     47   ($check-error (error-object-irritants))
     48   ($check-error (error-object-irritants e1 e2))
     49   ($check-error (error-object-irritants "not an error object")))
     50 
     51 ;; XXX system-error-continuation
     52 
     53 ($check-predicate (continuation? system-error-continuation))
     54 
     55 ($let*
     56     ( (catch-system-error
     57        ($lambda (proc)
     58          (guard-dynamic-extent
     59           ()
     60           proc
     61           (list (list system-error-continuation
     62                       ($lambda (obj divert)
     63                         ($let
     64                             ( ( ((service code message errno) . tail)
     65                                 (error-object-irritants obj)))
     66                           (apply divert (list* service code tail))))))))))
     67 
     68   ($check equal?
     69           (catch-system-error
     70            ($lambda ()
     71              (rename-file "nonexistent-file-name" "other-file-name")))
     72           (list "rename" "ENOENT" "nonexistent-file-name" "other-file-name")))