From 128cfa08508164959499418d029bac8c96e280e4 Mon Sep 17 00:00:00 2001
From: csr21 <unknown>
Date: Thu, 5 Jun 2003 15:18:22 -0400
Subject: [PATCH] A different approach to the "SBCL DEFCONSTANT" problem:
 instead of

A different approach to the "SBCL DEFCONSTANT" problem: instead of
sticking icky #+sbcl defconstant-eqx everywhere, concentrate the
nastiness in an :around method for ASDF:PERFORM on CLX-SOURCE-FILE.
This, of course, means that the sources do not build on sbcl if you
compile and load them one by one; I can live with that.

darcs-hash:20030605191822-ed5a3-3b02c39acf535f330f3313522984197a7a351ec8.gz
---
 clx.asd       | 31 +++++++++++++++++++++++--
 clx.lisp      | 63 +++++++++++++++------------------------------------
 depdefs.lisp  |  7 ++----
 gcontext.lisp |  5 +---
 image.lisp    | 37 ++++++++----------------------
 xvidmode.lisp |  6 ++---
 6 files changed, 62 insertions(+), 87 deletions(-)

diff --git a/clx.asd b/clx.asd
index 5f90189..4594980 100644
--- a/clx.asd
+++ b/clx.asd
@@ -66,11 +66,38 @@
 	(operation-on-failure o) :error)
   ;; a variety of accessors, such as AREF-CARD32, are not declared
   ;; INLINE.  Without this (non-ANSI) static-type-inference behaviour,
-  ;; SBCL emits about 100 optimization notes (roughly one fifth of all
-  ;; of the notes emitted).  Since the internals are unlikely to
+  ;; SBCL emits an extra 100 optimization notes (roughly one fifth of
+  ;; all of the notes emitted).  Since the internals are unlikely to
   ;; change much, and certainly the internals should stay in sync,
   ;; enabling this extension is a win.  (Note that the use of this
   ;; does not imply that applications using CLX calls that expand into
   ;; calls to these accessors will be optimized in the same way).
   (let ((sb-ext:*derive-function-types* t))
     (call-next-method)))
+
+#+sbcl
+(defmethod perform :around (o (f clx-source-file))
+  (handler-bind
+      ((sb-ext:defconstant-uneql
+	   (lambda (c)
+	     (let ((old (sb-ext:defconstant-uneql-old-value c))
+		   (new (sb-ext:defconstant-uneql-new-value c)))
+	       (typecase old
+		 (list (when (equal old new) (abort c)))
+		 (simple-vector
+		  (when (and (typep new 'simple-vector)
+			     (= (length old) (length new))
+			     (every #'eql old new))
+		    (abort c)))
+		 (array
+		  (when (and (typep new 'array)
+			     (equal (array-dimensions old)
+				    (array-dimensions new))
+			     (equal (array-element-type old)
+				    (array-element-type new))
+			     (dotimes (i (array-total-size old) t)
+			       (unless (eql (row-major-aref old i)
+					    (row-major-aref new i))
+				 (return nil))))
+		    (abort c))))))))
+    (call-next-method)))
diff --git a/clx.lisp b/clx.lisp
index 186f959..c44fd66 100644
--- a/clx.lisp
+++ b/clx.lisp
@@ -451,9 +451,7 @@
 
 (deftype xatom () '(or string symbol))
 
-(#-sbcl defconstant
- #+sbcl sb-int:defconstant-eqx
- +predefined-atoms+
+(defconstant +predefined-atoms+
  '#(nil :PRIMARY :SECONDARY :ARC :ATOM :BITMAP
     :CARDINAL :COLORMAP :CURSOR
     :CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3
@@ -473,8 +471,7 @@
     :ITALIC_ANGLE :X_HEIGHT :QUAD_WIDTH :WEIGHT
     :POINT_SIZE :RESOLUTION :COPYRIGHT :NOTICE
     :FONT_NAME :FAMILY_NAME :FULL_NAME :CAP_HEIGHT
-    :WM_CLASS :WM_TRANSIENT_FOR)
- #+sbcl #'equalp)
+    :WM_CLASS :WM_TRANSIENT_FOR))
 
 (deftype stringable () '(or string symbol))
 
@@ -484,25 +481,19 @@
 
 (deftype timestamp () '(or null card32))
 
-(#-sbcl defconstant
- #+sbcl sb-int:defconstant-eqx
- +bit-gravity-vector+
+(defconstant +bit-gravity-vector+
  '#(:forget :north-west :north :north-east :west
     :center :east :south-west :south
-    :south-east :static)
- #+sbcl #'equalp)
+    :south-east :static))
 
 (deftype bit-gravity ()
   '(member :forget :north-west :north :north-east :west
 	   :center :east :south-west :south :south-east :static))
 
-(#-sbcl defconstant
- #+sbcl sb-int:defconstant-eqx
- +win-gravity-vector+
+(defconstant +win-gravity-vector+
  '#(:unmap :north-west :north :north-east :west
     :center :east :south-west :south :south-east
-    :static)
- #+sbcl #'equalp)
+    :static))
 
 (defparameter *protocol-families*
   '(;; X11/X.h, Family*
@@ -569,16 +560,13 @@
     (write-string " " stream)
     (prin1 (gcontext-id gcontext) stream)))
 
-(#-sbcl defconstant
- #+sbcl sb-int:defconstant-eqx
- +event-mask-vector+
+(defconstant +event-mask-vector+
  '#(:key-press :key-release :button-press :button-release
     :enter-window :leave-window :pointer-motion :pointer-motion-hint
     :button-1-motion :button-2-motion :button-3-motion :button-4-motion
     :button-5-motion :button-motion :keymap-state :exposure :visibility-change
     :structure-notify :resize-redirect :substructure-notify :substructure-redirect
-    :focus-change :property-change :colormap-change :owner-grab-button)
- #+sbcl #'equalp)
+    :focus-change :property-change :colormap-change :owner-grab-button))
 
 (deftype event-mask-class ()
   '(member :key-press :key-release :owner-grab-button :button-press :button-release
@@ -591,14 +579,11 @@
 (deftype event-mask ()
   '(or mask32 (clx-list event-mask-class)))
 
-(#-sbcl defconstant
- #+sbcl sb-int:defconstant-eqx
- +pointer-event-mask-vector+
+(defconstant +pointer-event-mask-vector+
  '#(%error %error :button-press :button-release
     :enter-window :leave-window :pointer-motion :pointer-motion-hint
     :button-1-motion :button-2-motion :button-3-motion :button-4-motion
-    :button-5-motion :button-motion :keymap-state)
- #+sbcl #'equalp)
+    :button-5-motion :button-motion :keymap-state))
 
 (deftype pointer-event-mask-class ()
   '(member :button-press :button-release
@@ -609,13 +594,10 @@
 (deftype pointer-event-mask ()
   '(or mask32 (clx-list pointer-event-mask-class)))
 
-(#-sbcl defconstant
- #+sbcl sb-int:defconstant-eqx
- +device-event-mask-vector+
+(defconstant +device-event-mask-vector+
  '#(:key-press :key-release :button-press :button-release :pointer-motion
     :button-1-motion :button-2-motion :button-3-motion :button-4-motion
-    :button-5-motion :button-motion)
- #+sbcl #'equalp)
+    :button-5-motion :button-motion))
 
 (deftype device-event-mask-class ()
   '(member :key-press :key-release :button-press :button-release :pointer-motion
@@ -625,12 +607,9 @@
 (deftype device-event-mask ()
   '(or mask32 (clx-list device-event-mask-class)))
 
-(#-sbcl defconstant
- #+sbcl sb-int:defconstant-eqx
- +state-mask-vector+
+(defconstant +state-mask-vector+
  '#(:shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5
-    :button-1 :button-2 :button-3 :button-4 :button-5)
- #+sbcl #'equalp)
+    :button-1 :button-2 :button-3 :button-4 :button-5))
 
 (deftype modifier-key ()
   '(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5))
@@ -641,15 +620,12 @@
 (deftype state-mask-key ()
   '(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5)))
 
-(#-sbcl defconstant
- #+sbcl sb-int:defconstant-eqx
- +gcontext-components+
+(defconstant +gcontext-components+
  '(:function :plane-mask :foreground :background
    :line-width :line-style :cap-style :join-style :fill-style
    :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode
    :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes
-   :arc-mode)
- #+sbcl #'equalp)
+   :arc-mode))
 
 (deftype gcontext-key ()
   '(member :function :plane-mask :foreground :background
@@ -676,14 +652,11 @@
 (deftype draw-direction ()
   '(member :left-to-right :right-to-left))
 
-(#-sbcl defconstant
- #+sbcl sb-int:defconstant-eqx
- +boole-vector+
+(defconstant +boole-vector+
  '#(#.boole-clr #.boole-and #.boole-andc2 #.boole-1
     #.boole-andc1 #.boole-2 #.boole-xor #.boole-ior
     #.boole-nor #.boole-eqv #.boole-c2 #.boole-orc2
-    #.boole-c1 #.boole-orc1 #.boole-nand #.boole-set)
- #+sbcl #'equalp)
+    #.boole-c1 #.boole-orc1 #.boole-nand #.boole-set))
 
 (deftype boole-constant ()
   `(member ,boole-clr ,boole-and ,boole-andc2 ,boole-1
diff --git a/depdefs.lisp b/depdefs.lisp
index 35bc450..5e48917 100644
--- a/depdefs.lisp
+++ b/depdefs.lisp
@@ -117,17 +117,14 @@
 ;;; useful for much beyond xatoms and windows (since almost nothing else
 ;;; ever comes back in events).
 ;;;--------------------------------------------------------------------------
-(#-sbcl defconstant
- #+sbcl sb-int:defconstant-eqx
- +clx-cached-types+
+(defconstant +clx-cached-types+
  '(drawable
    window
    pixmap
    ;;		gcontext
    cursor
    colormap
-   font)
- #+sbcl #'equal)
+   font))
 
 (defmacro resource-id-map-test ()
   #+excl '#'equal
diff --git a/gcontext.lisp b/gcontext.lisp
index 43d1f51..d1f6308 100644
--- a/gcontext.lisp
+++ b/gcontext.lisp
@@ -48,10 +48,7 @@
 ;;	The state vector contains all card32s to speed server updating
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-(#-sbcl defconstant
- #+sbcl sb-int:defconstant-eqx
- +gcontext-fast-change-length+ #.(length +gcontext-components+)
- #+sbcl #'equal)
+(defconstant +gcontext-fast-change-length+ #.(length +gcontext-components+))
 
 (macrolet ((def-gc-internals (name &rest extras)
 	    (let ((macros nil)
diff --git a/image.lisp b/image.lisp
index 4bcc58c..8ec0352 100644
--- a/image.lisp
+++ b/image.lisp
@@ -59,16 +59,10 @@
     (write-string "x" stream)
     (prin1 (image-depth image) stream)))
 
-(#-sbcl defconstant
- #+sbcl sb-int:defconstant-eqx
- +empty-data-x+ '#.(make-sequence '(array card8 (*)) 0)
- #+sbcl #'equalp)
+(defconstant +empty-data-x+ '#.(make-sequence '(array card8 (*)) 0))
 
-(#-sbcl defconstant
- #+sbcl sb-int:defconstant-eqx
- +empty-data-z+
- '#.(make-array '(0 0) :element-type 'pixarray-1-element-type)
- #+sbcl #'equalp)
+(defconstant +empty-data-z+
+  '#.(make-array '(0 0) :element-type 'pixarray-1-element-type))
 
 (def-clx-class (image-x (:include image) (:copier nil)
 			(:print-function print-image))
@@ -471,9 +465,7 @@
 			    (byte 4 4)
 			    (the card4 (ldb (byte 4 4) byte2)))))))))))
 
-(#-sbcl defconstant
- #+sbcl sb-int:defconstant-eqx
- +image-byte-reverse+
+(defconstant +image-byte-reverse+
  '#.(coerce
      '#(
 	0 128 64 192 32 160 96 224 16 144 80 208 48 176 112 240
@@ -492,8 +484,7 @@
 	11 139 75 203 43 171 107 235 27 155 91 219 59 187 123 251
 	7 135 71 199 39 167 103 231 23 151 87 215 55 183 119 247
 	15 143 79 207 47 175 111 239 31 159 95 223 63 191 127 255)
-     '(vector card8))
-  #+sbcl #'equalp)
+     '(vector card8)))
 
 (defun image-swap-bits
        (src dest srcoff destoff srclen srcinc destinc height lsb-first-p)
@@ -709,10 +700,7 @@
 ;;; 	lr  l+R
 ;;; 	wr  w+R
 
-(#-sbcl defconstant
- #+sbcl sb-int:defconstant-eqx
-	
- +image-swap-function+
+(defconstant +image-swap-function+
  '#.(make-array
      '(12 12) :initial-contents
      (let ((n  'image-noswap)
@@ -723,7 +711,7 @@
 	   (sr 'image-swap-bits-and-two-bytes)
 	   (lr 'image-swap-bits-and-four-bytes)
 	   (wr 'image-swap-bits-and-words))
-       (list #|             1Mm 2Mm 4Mm 1Ml 2Ml 4Ml 1Lm 2Lm 4Lm 1Ll 2Ll 4Ll  |#
+       (list  #|       1Mm 2Mm 4Mm 1Ml 2Ml 4Ml 1Lm 2Lm 4Lm 1Ll 2Ll 4Ll  |#
 	(list #| 1Mm |# n   n   n   r   sr  lr  n   s   l   r   r   r )
 	(list #| 2Mm |# n   n   n   r   sr  lr  n   s   l   r   r   r )
 	(list #| 4Mm |# n   n   n   r   sr  lr  n   s   l   r   r   r )
@@ -735,8 +723,7 @@
 	(list #| 4Lm |# l   l   l   lr  wr  r   l   w   n   lr  lr  lr)
 	(list #| 1Ll |# r   r   r   n   s   l   r   sr  lr  n   n   n )
 	(list #| 2Ll |# r   r   r   n   s   l   r   sr  lr  n   n   n )
-	(list #| 4Ll |# r   r   r   n   s   l   r   sr  lr  n   n   n ))))
-  #+sbcl #'equalp)
+	(list #| 4Ll |# r   r   r   n   s   l   r   sr  lr  n   n   n )))))
 
 ;;; Of course, the table above is a lie.  We also need to factor in the
 ;;; order of the source data to cope with swapping half of a unit at the
@@ -745,10 +732,7 @@
 ;;;
 ;;; Defines whether the first half of a unit has the first half of the data
 
-(#-sbcl defconstant
- #+sbcl sb-int:defconstant-eqx
-	
- +image-swap-lsb-first-p+
+(defconstant +image-swap-lsb-first-p+
  '#.(make-array
      12 :initial-contents
      (list t   #| 1mm |#
@@ -763,8 +747,7 @@
 	   t   #| 1ll |#
 	   t   #| 2ll |#
 	   t   #| 4ll |#
-	   ))
- #+sbcl #'equalp)
+	   )))
 
 (defun image-swap-function
        (bits-per-pixel
diff --git a/xvidmode.lisp b/xvidmode.lisp
index e1c6bac..a83f6eb 100644
--- a/xvidmode.lisp
+++ b/xvidmode.lisp
@@ -353,8 +353,7 @@ mode will occur first. The last remaining mode can not be deleted."
       (card32 (screen-position scr dpy))
       ((sequence :format card16) v))))
 
-(#-sbcl defconstant
- #+sbcl sb-int:defconstant-eqx +mode-status+
+(defconstant +mode-status+
   '#(:MODE_BAD             ; unspecified reason 
      :MODE_ERROR           ; error condition 
      :MODE_OK              ; Mode OK 
@@ -391,8 +390,7 @@ mode will occur first. The last remaining mode can not be deleted."
      :MODE_ONE_WIDTH       ; only one width is supported 
      :MODE_ONE_HEIGHT      ; only one height is supported 
      :MODE_ONE_SIZE        ; only one resolution is supported 
-     )
-  #+sbcl #'equalp)
+     ))
 
 (defun decode-status-mode (status)
   (declare (type int32 status))
-- 
GitLab