71 lines
2.2 KiB
Scheme
71 lines
2.2 KiB
Scheme
(define-record-type x-error :x-error
|
|
(really-make-x-error display ser-num code major-opcode minor-opcode res-id text next)
|
|
x-error?
|
|
(display x-error-display)
|
|
(ser-num x-error-ser-num)
|
|
(code x-error-code)
|
|
(major-opcode x-error-major-opcode)
|
|
(minor-opcode x-error-minor-opcode)
|
|
(res-id x-error-res-id)
|
|
(text x-error-text)
|
|
(next really-next-x-error really-set-next-x-error!))
|
|
|
|
(define (make-x-error display ser-num code major-opcode minor-opcode res-id text)
|
|
(really-make-x-error display ser-num code major-opcode
|
|
minor-opcode res-id text (make-placeholder)))
|
|
|
|
(define (next-x-error x-error)
|
|
(placeholder-value (really-next-x-error x-error)))
|
|
|
|
(define (set-next-x-error! x-error next-x-error)
|
|
(placeholder-set! (really-next-x-error x-error) next-x-error))
|
|
|
|
(define empty-x-error (make-x-error #f #f #f #f #f #f #f))
|
|
(define (empty-x-error? obj)
|
|
(eq? obj empty-x-error))
|
|
|
|
(define *most-recent-x-error* empty-x-error)
|
|
|
|
(define (most-recent-x-error)
|
|
*most-recent-x-error*)
|
|
|
|
(define (advance-most-recent-x-error!)
|
|
(set! *most-recent-x-error*
|
|
(next-x-error *most-recent-x-error*)))
|
|
|
|
|
|
(define internal-x-error-handler
|
|
(lambda (infos)
|
|
(let ((display (make-display (vector-ref infos 0) #f))
|
|
(ser-num (vector-ref infos 1))
|
|
(error-code (vector-ref infos 2))
|
|
(major-opcode (vector-ref infos 3))
|
|
(minor-opcode (vector-ref infos 4))
|
|
(res-id (vector-ref infos 5))
|
|
(error-string (vector-ref infos 6)))
|
|
(set-next-x-error! *most-recent-x-error*
|
|
(make-x-error display ser-num error-code major-opcode
|
|
minor-opcode res-id error-string))
|
|
(advance-most-recent-x-error!))))
|
|
|
|
(define-exported-binding "internal-x-error-handler" internal-x-error-handler)
|
|
|
|
;;; Fatal errors are handled by an ordinary handler
|
|
(define *x-fatal-error-handler* #f)
|
|
|
|
(define internal-x-fatal-error-handler
|
|
(lambda (Xdisplay)
|
|
(if *x-fatal-error-handler*
|
|
(*x-fatal-error-handler* (make-display Xdisplay #f))
|
|
#f)))
|
|
|
|
(define-exported-binding "internal-x-fatal-error-handler"
|
|
internal-x-fatal-error-handler)
|
|
|
|
(define (x-fatal-error-handler . args)
|
|
(if (null? args)
|
|
*x-fatal-error-handler*
|
|
(let ((old-hander *x-fatal-error-handler*))
|
|
(set! *x-fatal-error-handler* (car args))
|
|
old-hander)))
|