gerbil/src/std/error.ss at master · phillipwood/gerbil · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
;;; -*- Gerbil -*-
;;; (C) vyzo
;;; Gerbil error objects
package: std

(export #t)

(defsyntax exception
  (make-runtime-struct-info
   runtime-identifier: (quote-syntax exception::t)))

(defsyntax <error>
  (make-runtime-struct-info
   runtime-identifier: (quote-syntax error::t)))

(defmethod {display-exception <error>}
  (lambda (self port)
    (parameterize ((current-output-port port))
      (cond
       ((error-trace self)
        => (lambda (where) (display* where ": "))))
      (display* "[" (##type-name (object-type self)) "] ")
      (displayln (error-message self))
      (let (irritants (error-irritants self))
        (unless (null? irritants)
          (display "--- irritants: ")
          (for-each
            (lambda (obj) (display* obj " "))
            irritants)
          (newline))))))

(defstruct (io-error <error>) ())
(defstruct (timeout-error <error>) ())

(def (raise-io-error where what . irritants)
  (raise (make-io-error what irritants where)))

(def (raise-timeout where what . irritants)
  (raise (make-timeout-error what irritants where)))