RWS@ZERMATT.LCS.MIT.EDU (Robert Scheifler) (11/02/87)
SYNOPSIS:
missing values in pixmap-format-bits-per-pixel type
various missing -equal functions
various function symbols not exported that should be
buggy OR type expansion
get-property sometimes returned non-nil when it shouldn't
FIX:
4 files: lib/CLX/clx.l, lib/CLX/macros.l,
lib/CLX/attributes.l, lib/CLX/requests.l
*** lib/CLX/clx.l.old Tue Oct 13 13:06:47 1987
--- lib/CLX/clx.l Mon Nov 2 08:49:49 1987
***************
*** 190,196 ****
(defstruct pixmap-format
(depth 0 :type image-depth)
! (bits-per-pixel 8 :type (member 4 8 16 32))
(scanline-pad 8 :type (member 8 16 32)))
(defparameter *atom-cache-size* 200)
--- 190,196 ----
(defstruct pixmap-format
(depth 0 :type image-depth)
! (bits-per-pixel 8 :type (member 1 4 8 16 24 32))
(scanline-pad 8 :type (member 8 16 32)))
(defparameter *atom-cache-size* 200)
***************
*** 596,601 ****
--- 596,627 ----
(declare-values (or null int32))
(getf (font-properties font) name))
+ (eval-when (eval compile) ;; I'd rather use macrolet, but Symbolics doesn't like it...
+
+ (defmacro make-mumble-equal (type)
+ ;; When cached, EQ works fine, otherwise test resource id's and displays
+ (let ((predicate (xintern type "-EQUAL"))
+ (id (xintern type "-ID"))
+ (dpy (xintern type "-DISPLAY")))
+ (if (member type *clx-cached-types*)
+ `(within-definition (,type make-mumble-equal)
+ (proclaim '(inline ,predicate))
+ (defun ,predicate (a b) (eq a b)))
+ `(within-definition (,type make-mumble-equal)
+ (defun ,predicate (a b)
+ (declare (type ,type a b))
+ (and (= (,id a) (,id b))
+ (eq (,dpy a) (,dpy b))))))))
+
+ ) ;; End eval-when
+
+ (make-mumble-equal window)
+ (make-mumble-equal pixmap)
+ (make-mumble-equal cursor)
+ (make-mumble-equal font)
+ (make-mumble-equal gcontext)
+ (make-mumble-equal colormap)
+ (make-mumble-equal drawable)
;;;
;;; Event-mask encode/decode functions
***************
*** 697,702 ****
--- 723,729 ----
pixel
image-depth
display
+ display-p
display-display
display-after-function
display-protocol-major-version
***************
*** 725,730 ****
--- 752,758 ----
display-authorization-data
display-plist
color
+ color-p
color-red
color-green
color-blue
***************
*** 732,749 ****
--- 760,787 ----
color-rgb
resource-id
drawable
+ drawable-p
+ drawable-equal
drawable-id
drawable-display
window
+ window-p
+ window-equal
window-id
window-display
pixmap
+ pixmap-p
+ pixmap-equal
pixmap-id
pixmap-display
colormap
+ colormap-p
+ colormap-equal
colormap-id
colormap-display
cursor
+ cursor-p
+ cursor-equal
cursor-id
cursor-display
xatom
***************
*** 761,766 ****
--- 799,806 ----
rect-seq
arc-seq
gcontext
+ gcontext-p
+ gcontext-equal
gcontext-id
gcontext-display
event-mask-class
***************
*** 778,786 ****
--- 818,843 ----
draw-direction
boole-constant
bitmap-format
+ bitmap-format-p
+ bitmap-format-unit
+ bitmap-format-pad
+ bitmap-format-lsb-first-p
pixmap-format
+ pixmap-format-p
+ pixmap-format-depth
+ pixmap-format-bits-per-pixel
+ pixmap-format-scanline-pad
visual-info
+ visual-info-p
+ visual-info-id
+ visual-info-class
+ visual-info-red-mask
+ visual-info-green-mask
+ visual-info-blue-mask
+ visual-info-bits-per-rgb
+ visual-info-colormap-entries
screen
+ screen-p
screen-root
screen-width
screen-height
***************
*** 798,803 ****
--- 855,862 ----
screen-save-unders-p
screen-event-mask-at-open
font
+ font-p
+ font-equal
font-id
font-display
font-name
*** lib/CLX/macros.l.old Thu Sep 10 18:20:35 1987
--- lib/CLX/macros.l Mon Nov 2 08:25:26 1987
***************
*** 450,456 ****
;; when using event-case. This is pretty gross.
(defmacro or-expand (&rest forms &environment environment)
! `(or ,@(mapcar #'(lambda (form) (macroexpand form environment)) forms)))
;;
;; the OR type
--- 450,460 ----
;; when using event-case. This is pretty gross.
(defmacro or-expand (&rest forms &environment environment)
! `(cond ,@(mapcar #'(lambda (forms)
! (mapcar #'(lambda (form)
! (macroexpand form environment))
! forms))
! forms)))
;;
;; the OR type
***************
*** 471,479 ****
(when (consp item)
(setq args (cdr item)
item (car item)))
! (push
! `(,(getify item) ,index ,@args)
! result))))
((index value &rest type-list)
(do ((types type-list (cdr types))
--- 475,485 ----
(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)))))
((index value &rest type-list)
(do ((types type-list (cdr types))
***************
*** 558,563 ****
--- 564,576 ----
(setf (aref-card32 buffer-lbuf (incf ,index)) ,value)
#-clx-overlapping-arrays
(setf (aref-card32 buffer-bbuf (incf ,index 4)) ,value)))
+ (write-card29 (index value)
+ `(progn
+ (setq %mask (logior %mask ,%mask-bit))
+ #+clx-overlapping-arrays
+ (setf (aref-card29 buffer-lbuf (incf ,index)) ,value)
+ #-clx-overlapping-arrays
+ (setf (aref-card29 buffer-bbuf (incf ,index 4)) ,value)))
(null-put (index value) index value nil))
,@(let ((%bit 1))
(get-put-items index-var type-values t
*** lib/CLX/attributes.l.old Tue Oct 20 16:29:38 1987
--- lib/CLX/attributes.l Mon Nov 2 08:26:01 1987
***************
*** 63,77 ****
(defmacro state-geometry (state) `(fourth ,state))
(defmacro state-geometry-changes (state) `(fifth ,state))
- ;; If drawable's ID's aren't cached, then window objects
- ;; may not be EQ for the same window. This has implications
- ;; for WITH-STATE
-
- (defun drawable-equal (a b)
- (or (eq a b)
- (and (= (drawable-id a) (drawable-id b))
- (eq (drawable-display a) (drawable-display b)))))
-
(defmacro drawable-equal-function ()
(if (member 'drawable *clx-cached-types*)
''eq ;; Allows the compiler to use the microcoded ASSQ primitive on LISPM's
*** lib/CLX/requests.l.old Thu Sep 10 18:21:55 1987
--- lib/CLX/requests.l Mon Nov 2 08:26:40 1987
***************
*** 319,325 ****
(type t transform)) ;(or null (function (integer) t))
(declare-values data (or null type) format bytes-after)
(let ((display (window-display window))
! data reply-type reply-format bytes-after)
(setq property (intern-atom display property))
(when type (setq type (intern-atom display type)))
(with-display (display)
--- 319,326 ----
(type t transform)) ;(or null (function (integer) t))
(declare-values data (or null type) format bytes-after)
(let ((display (window-display window))
! (data nil)
! reply-type reply-format bytes-after)
(setq property (intern-atom display property))
(when type (setq type (intern-atom display type)))
(with-display (display)
***************
*** 335,351 ****
reply-type (card32-get 8)
bytes-after (card32-get 12))
(let ((nitems (card32-get 16)))
! (setq data
! (ecase reply-format
! (0 nil) ;; (make-sequence result-type 0)) ;; Property not found.
! (8 (sequence-get :result-type result-type :format card8
! :length nitems :transform transform))
!
! (16 (sequence-get :result-type result-type :format card16
! :length nitems :transform transform))
!
! (32 (sequence-get :result-type result-type :format card32
! :length nitems :transform transform)))))))
(display-invoke-after-function display)
(values data (and (plusp reply-type) (lookup-xatom display reply-type))
reply-format bytes-after)))
--- 336,353 ----
reply-type (card32-get 8)
bytes-after (card32-get 12))
(let ((nitems (card32-get 16)))
! (when (plusp nitems)
! (setq data
! (ecase reply-format
! (0 nil) ;; (make-sequence result-type 0)) ;; Property not found.
! (8 (sequence-get :result-type result-type :format card8
! :length nitems :transform transform))
!
! (16 (sequence-get :result-type result-type :format card16
! :length nitems :transform transform))
!
! (32 (sequence-get :result-type result-type :format card32
! :length nitems :transform transform))))))))
(display-invoke-after-function display)
(values data (and (plusp reply-type) (lookup-xatom display reply-type))
reply-format bytes-after)))