From 20fc229b081a1e0d79f285b76606d041220d19ad Mon Sep 17 00:00:00 2001
From: mainzelm <mainzelm>
Date: Wed, 19 Dec 2001 21:37:16 +0000
Subject: [PATCH] Error handling similar to sigevents

---
 scheme/xlib/error.scm           | 69 ++++++++++++++++++++++++---------
 scheme/xlib/xlib-interfaces.scm | 10 ++++-
 scheme/xlib/xlib-packages.scm   |  2 +
 3 files changed, 62 insertions(+), 19 deletions(-)

diff --git a/scheme/xlib/error.scm b/scheme/xlib/error.scm
index a867f53..14077fc 100644
--- a/scheme/xlib/error.scm
+++ b/scheme/xlib/error.scm
@@ -1,26 +1,57 @@
-(define *x-error-handler* #f)
-(define *x-fatal-error-handler* #f)
+(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)
-    (if *x-error-handler*
-	(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)))
-	  (*x-error-handler* display ser-num error-code major-opcode
-			     minor-opcode res-id error-string))
-	#f)))
+    (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)
 
-(define (x-error-handler . args)
-  (if (null? args)
-      *x-error-handler*
-      (set! *x-error-handler* (car args))))
+;;; Fatal errors are handled by an ordinary handler
+(define *x-fatal-error-handler* #f)
 
 (define internal-x-fatal-error-handler
   (lambda (Xdisplay)
@@ -34,4 +65,6 @@
 (define (x-fatal-error-handler . args)
   (if (null? args)
       *x-fatal-error-handler*
-      (set! *x-fatal-error-handler* (car args))))
+      (let ((old-hander *x-fatal-error-handler*))
+	(set! *x-fatal-error-handler* (car args))
+	old-hander)))
diff --git a/scheme/xlib/xlib-interfaces.scm b/scheme/xlib/xlib-interfaces.scm
index ffa12ac..ca85bd6 100644
--- a/scheme/xlib/xlib-interfaces.scm
+++ b/scheme/xlib/xlib-interfaces.scm
@@ -409,7 +409,15 @@
 	  refresh-keyboard-mapping))
 
 (define-interface xlib-error-interface
-  (export x-error-handler
+  (export x-error-display
+	  x-error-ser-num
+	  x-error-code
+	  x-error-major-opcode
+	  x-error-minor-opcode
+	  x-error-res-id
+	  x-error-text
+	  most-recent-x-error
+	  next-x-error
 	  x-fatal-error-handler))
 
 (define-interface xlib-extension-interface
diff --git a/scheme/xlib/xlib-packages.scm b/scheme/xlib/xlib-packages.scm
index 05d1d09..0fb934c 100644
--- a/scheme/xlib/xlib-packages.scm
+++ b/scheme/xlib/xlib-packages.scm
@@ -137,6 +137,8 @@
 (define-structure xlib-error xlib-error-interface
   (open scheme
 	external-calls
+	placeholders
+	define-record-types
 	xlib-types)
   (files error))