From 1f2b6f3fd83880c073f37b06bbfcf2f70e29527c Mon Sep 17 00:00:00 2001
From: Daniel Kochmanski <daniel@turtleware.eu>
Date: Sat, 8 Dec 2018 09:32:51 +0100
Subject: [PATCH] OR-GET accessor accepts only two types.

First one must be enum (either NULL or MEMBER).

Otherwise if the first type didn't match we could have a condition signalled by
a type-check or by other assertions generated by the compiler (deduced from a
declaration).

Solves a problem with setting a gc-clip mask to a pixmap (it recently started
erroring due to compiler enforcing declarations, but previously didn't work as
well). We fix other OR-GET references in the code to have the correct order.

Closes #97 (and numerous McCLIM issues).
---
 extensions/shape.lisp |  2 +-
 macros.lisp           | 56 ++++++++++++++++++++-----------------------
 requests.lisp         |  8 +++----
 3 files changed, 31 insertions(+), 35 deletions(-)

diff --git a/extensions/shape.lisp b/extensions/shape.lisp
index 6171c67..b011291 100644
--- a/extensions/shape.lisp
+++ b/extensions/shape.lisp
@@ -107,7 +107,7 @@
       (window window)
       (int16 x-offset)
       (int16 y-offset)
-      ((or pixmap (member :none)) pixmap))))
+      ((or (member :none) pixmap) pixmap))))
 
 (defun shape-combine (window source-window
                              &key (kind :bounding)
diff --git a/macros.lisp b/macros.lisp
index c64ae89..57a3ae6 100644
--- a/macros.lisp
+++ b/macros.lisp
@@ -479,41 +479,37 @@
                   `(,(putify stuff) 1 ,thing)))
        `(and (type? ,thing 'card8) (write-card8 1 ,thing)))))
 
-;; Macroexpand the result of OR-GET to allow the macros file to not be loaded
-;; when using event-case.  This is pretty gross.
-
-(defmacro or-expand (&rest forms &environment environment)
-  `(cond ,@(mapcar #'(lambda (forms)
-                       (mapcar #'(lambda (form)
-                                   (clx-macroexpand form environment))
-                               forms))
-                   forms)))
-
 ;;
 ;; the OR type
 ;;
 (define-accessor or (32)
-  ;; Select from among several types (usually NULL and something else)
+  ;; Select from among two types (NULL/MEMBER and something else).
   ((index &rest type-list &environment environment)
-   (do ((types type-list (cdr types))
-        (value (gensym))
-        (result))
-       ((endp types)
-        `(let ((,value (read-card32 ,index)))
-           (macrolet ((read-card32 (index) index ',value)
-                      (read-card29 (index) index ',value))
-             ,(clx-macroexpand `(or-expand ,@(nreverse result)) environment))))
-     (let ((item (car types))
-           (args nil))
-       (when (consp item)
-         (setq args (cdr item)
-               item (car item)))
-       (if (eq item 'null)  ;; Special case for NULL
-           (push `((zerop ,value) nil) result)
-           (push
-            `((,(getify item) ,index ,@args))
-            result)))))
-
+   ;; OR-GET accessor accepts only two types. The first one must enum (either
+   ;; null or a member specifier). Otherwise if the first type didn't match we
+   ;; could have a condition signalled by a type-check or by other assertions
+   ;; generated by the compiler (deduced from declarations). -- jd 2018-11-07
+   (unless (= (length type-list) 2)
+     (x-type-error type-list '(or enum t) "an alternative of enum and other type."))
+   (let ((value (gensym)))
+     (flet ((static-check (item &aux args)
+              (when (consp item)
+                (setf args (cdr item)
+                      item (car item)))
+              (ecase item
+                (null   `((zerop ,value) nil))
+                (member `((<= 0 ,value ,(length args))
+                          (svref ',(apply #'vector args) ,value)))))
+            (dynamic-check (item &aux args)
+              (when (consp item)
+                (setf args (cdr item)
+                      item (car item)))
+              `(,(getify item) ,index ,@args)))
+       `(let ((,value (read-card32 ,index)))
+          (macrolet ((read-card32 (index) index ',value)
+                     (read-card29 (index) index ',value))
+            (if ,@(static-check (first type-list))
+                ,(dynamic-check (second type-list))))))))
   ((index value &rest type-list)
    (do ((types type-list (cdr types))
         (result))
diff --git a/requests.lisp b/requests.lisp
index e802919..6ccf1f3 100644
--- a/requests.lisp
+++ b/requests.lisp
@@ -464,7 +464,7 @@
   ;; with declare-event, except that both resource-ids and resource objects are
   ;; accepted in the event components.  The display argument is only required if the
   ;; window is :pointer-window or :input-focus.
-  (declare (type (or window (member :pointer-window :input-focus)) window)
+  (declare (type (or (member :pointer-window :input-focus) window) window)
 	   (type event-key event-key)
 	   (type (or null event-mask) event-mask)
 	   (type generalized-boolean propagate-p)
@@ -756,7 +756,7 @@
 	   (type timestamp time))
   (with-buffer-request (display +x-setinputfocus+)
     ((data (member :none :pointer-root :parent)) revert-to)
-    ((or window (member :none :pointer-root)) focus)
+    ((or (member :none :pointer-root) window) focus)
     ((or null card32) time)))
 
 (defun input-focus (display)
@@ -765,8 +765,8 @@
   (with-buffer-request-and-reply (display +x-getinputfocus+ 16 :sizes (8 32))
        ()
     (values
-      (or-get 8 window (member :none :pointer-root))
-      (member8-get 1 :none :pointer-root :parent))))
+     (or-get 8 (member :none :pointer-root) window)
+     (member8-get 1 :none :pointer-root :parent))))
 
 (defun query-keymap (display &optional bit-vector)
   (declare (type display display)