scx/scheme/xlib/error.scm

;; 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))