; Library for manipulating Pocket Scheme exceptions
; 1-May-1999 goetter

(define (exn? x) (and (pair? x) (symbol? (car x))))
(define (exn-is? exn type) (and (exn? exn) (eq? type (car exn))))
(define (make-exn type msg obj) (cons type (cons msg obj)))
(define (exn:get-type x) (car x))
(define (exn:get-message x) (cadr x))
(define (exn:get-object x) (cddr x))

; given exn:x, generates procedures exn:x? and make-exn:x
(define-macro (define-exn type)
 `(begin
   (define (,(string->symbol (string-append (symbol->string type) "?")) x)
    (exn-is? x ',type))
   (define (,(string->symbol (string-append "make-" (symbol->string type))) msg obj)
    (make-exn ',type msg obj))))

(define-exn exn:heap)  	; A heap panic that can be handled.
(define-exn exn:io)		; I/O errors. Names the offending port
(define-exn exn:syntax)
(define-exn exn:eval)
(define-exn exn:read)	; reader (but not I/O) errors
(define-exn exn:math)	; math errors, sigfpe
(define-exn exn:type)	; wta
(define-exn exn:range)	; vector references, int to char, etc
(define-exn exn:user)	; the error subr
(define-exn exn:break)	; Scheme/Break from the UI, sigint
(define-exn exn:generic) ; legacy old-code exception, could be anything

; special accessor for exn:io
(define (exn:io:get-port x)
 (let retry ((o (exn:get-object x)))
  (cond ((null? o) #f)
        ((or (input-port? o) (output-port? o)) o)
        ((pair? o) (retry (car o)))
        (else #f) )))