109 lines
3.7 KiB
Scheme
109 lines
3.7 KiB
Scheme
;; Copyright (c) 2001-2003 by Norbert Freudemann, David Frese
|
|
|
|
;; *** x errors ******************************************************
|
|
|
|
(define-record-type x-error :x-error
|
|
(make-x-error display serial code major-opcode minor-opcode resource-id text)
|
|
x-error?
|
|
(display x-error:display)
|
|
(serial x-error:serial)
|
|
(code x-error:code)
|
|
(major-opcode x-error:major-opcode)
|
|
(minor-opcode x-error:minor-opcode)
|
|
(resource-id x-error:resource-id)
|
|
(text x-error:text))
|
|
|
|
(define-exported-binding "scx-x-error" :x-error)
|
|
|
|
(define-enumerated-type error-code :error-code
|
|
error-code? error-codes error-code-name error-code-index
|
|
(success bad-request bad-value bad-window bad-pixmap bad-atom
|
|
bad-cursor bad-font bad-match bad-drawable bad-access bad-alloc
|
|
bad-color bad-gc bad-id-choice bad-name bad-length bad-implementation))
|
|
|
|
(define-exported-binding "scx-error-code" :error-code)
|
|
(define-exported-binding "scx-error-codes" error-codes)
|
|
|
|
;; *** error exceptions **********************************************
|
|
|
|
;; Call synchronize to have the exceptions signaled where they belong to.
|
|
|
|
(define (use-x-error-exceptions!)
|
|
(set-error-handler! (lambda (display error)
|
|
(error "x-exception: " display error)))) ;; TODO
|
|
|
|
;; *** error-queue ***************************************************
|
|
|
|
;; Interface:
|
|
;; (use-x-error-queue!) returns a thunk that returns the most recent queue
|
|
;; element.
|
|
;; (empty-x-error-queue? q) return #t only for the initial queue.
|
|
;; (next-x-error-queue q) returns the next queue element, blocks if necessary.
|
|
;; (x-error-queue:this q) returns the x-error of that queue.
|
|
|
|
(define (use-x-error-queue!) ;; exp
|
|
(let* ((most-recent-x-error-queue empty-x-error-queue)
|
|
(handler (lambda (display error)
|
|
(set-next-x-error-queue! most-recent-x-error-queue
|
|
(make-x-error-queue error))
|
|
(set! most-recent-x-error-queue
|
|
(next-x-error-queue most-recent-x-error-queue)))))
|
|
(set-error-handler! handler)
|
|
(lambda () most-recent-x-error-queue)))
|
|
|
|
(define-record-type x-error-queue :x-error-queue
|
|
(really-make-x-error-queue this next)
|
|
x-error-queue?
|
|
(this x-error-queue:this)
|
|
(next really-next-x-error-queue really-set-next-x-error-queue!))
|
|
|
|
(define (make-x-error-queue error)
|
|
(really-make-x-error-queue error (make-placeholder)))
|
|
|
|
(define empty-x-error-queue (make-x-error-queue #f))
|
|
(define (empty-x-error-queue? obj)
|
|
(eq? obj empty-x-error-queue))
|
|
|
|
(define (next-x-error-queue x-error-queue)
|
|
(placeholder-value (really-next-x-error-queue x-error-queue)))
|
|
|
|
(define (set-next-x-error-queue! x-error-queue next-x-error-queue)
|
|
(placeholder-set! (really-next-x-error-queue x-error-queue)
|
|
next-x-error-queue))
|
|
|
|
;; *** default error handlers ****************************************
|
|
|
|
(import-lambda-definition %set-error-handler (handler)
|
|
"scx_Set_Error_Handler")
|
|
|
|
(import-lambda-definition call-c-error-handler (pointer display event)
|
|
"scx_Call_C_Error_Handler")
|
|
|
|
(define (set-error-handler! handler)
|
|
(let ((res (%set-error-handler handler)))
|
|
(if (number? res)
|
|
(lambda (display event) (call-c-error-handler (res display event)))
|
|
res)))
|
|
|
|
(import-lambda-definition get-error-text (display code)
|
|
"scx_Get_Error_Text")
|
|
|
|
(import-lambda-definition get-error-database-text
|
|
(display name message default-string)
|
|
"scx_Get_Error_Database_Text")
|
|
|
|
;(import-lambda-definition %set-io-error-handler (handler)
|
|
; "scx_Set_IO_Error_Handler")
|
|
|
|
(define *x-fatal-error-handler* ;; TODO do it like above??
|
|
(lambda (display)
|
|
#f))
|
|
|
|
(define-exported-binding "internal-x-fatal-error-handler"
|
|
*x-fatal-error-handler*)
|
|
|
|
(define (set-io-error-handler handler)
|
|
(let ((old-handler *x-fatal-error-handler*))
|
|
(set! *x-fatal-error-handler* handler)
|
|
old-handler))
|