/[cmucl]/src/clx/clx.lisp
ViewVC logotype

Diff of /src/clx/clx.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.5.1.1 by ram, Wed Jul 21 07:25:55 1993 UTC revision 1.16 by rtoy, Wed Jun 17 18:22:45 2009 UTC
# Line 76  Line 76 
76  ;;; objects, and the additional functionality to match the C Xlib is still in  ;;; objects, and the additional functionality to match the C Xlib is still in
77  ;;; progress.  Bug reports should be addressed to bug-clx@expo.lcs.mit.edu.  ;;; progress.  Bug reports should be addressed to bug-clx@expo.lcs.mit.edu.
78    
79    #+cmu
80    (ext:file-comment "$Id$")
81    
82  ;; Note: all of the following is in the package XLIB.  ;; Note: all of the following is in the package XLIB.
83    
84  (in-package :xlib)  (in-package :xlib)
# Line 83  Line 86 
86  (pushnew :clx *features*)  (pushnew :clx *features*)
87  (pushnew :xlib *features*)  (pushnew :xlib *features*)
88    
89  (defparameter *version* "MIT R5.01")  (defparameter *version* "Telent CLX 0.7.3 + CMUCL mods, based on MIT R5.02")
90  (pushnew :clx-mit-r4 *features*)  (pushnew :clx-mit-r4 *features*)
91  (pushnew :clx-mit-r5 *features*)  (pushnew :clx-mit-r5 *features*)
92    
# Line 138  Line 141 
141  ;  (declare (type <mumble> <mumble>-1 <mumble>-2)  ;  (declare (type <mumble> <mumble>-1 <mumble>-2)
142  ;          (clx-values boolean)))  ;          (clx-values boolean)))
143    
144  (deftype boolean () '(or null (not null)))  
145    (deftype generalized-boolean () 't)     ; (or null (not null))
146    
147  (deftype card32 () '(unsigned-byte 32))  (deftype card32 () '(unsigned-byte 32))
148    
# Line 158  Line 162 
162    
163  (deftype card4 () '(unsigned-byte 4))  (deftype card4 () '(unsigned-byte 4))
164    
165  #-(or clx-ansi-common-lisp cmu)  #-clx-ansi-common-lisp
166  (deftype real (&optional (min '*) (max '*))  (deftype real (&optional (min '*) (max '*))
167    (labels ((convert (limit floatp)    (labels ((convert (limit floatp)
168               (typecase limit               (typecase limit
# Line 168  Line 172 
172      `(or (float ,(convert min t) ,(convert max t))      `(or (float ,(convert min t) ,(convert max t))
173           (rational ,(convert min nil) ,(convert max nil)))))           (rational ,(convert min nil) ,(convert max nil)))))
174    
175  #-(or clx-ansi-common-lisp cmu)  #-clx-ansi-common-lisp
176  (deftype base-char ()  (deftype base-char ()
177    'string-char)    'string-char)
178    
# Line 228  Line 232 
232  (def-clx-class (bitmap-format (:copier nil) (:print-function print-bitmap-format))  (def-clx-class (bitmap-format (:copier nil) (:print-function print-bitmap-format))
233    (unit 8 :type (member 8 16 32))    (unit 8 :type (member 8 16 32))
234    (pad 8 :type (member 8 16 32))    (pad 8 :type (member 8 16 32))
235    (lsb-first-p nil :type boolean))    (lsb-first-p nil :type generalized-boolean))
236    
237  (defun print-bitmap-format (bitmap-format stream depth)  (defun print-bitmap-format (bitmap-format stream depth)
238    (declare (type bitmap-format bitmap-format)    (declare (type bitmap-format bitmap-format)
# Line 241  Line 245 
245    
246  (def-clx-class (pixmap-format (:copier nil) (:print-function print-pixmap-format))  (def-clx-class (pixmap-format (:copier nil) (:print-function print-pixmap-format))
247    (depth 0 :type image-depth)    (depth 0 :type image-depth)
248    (bits-per-pixel 8 :type (member 1 4 8 16 24 32))    (bits-per-pixel 8 :type (member 1 4 8 12 16 24 32))
249    (scanline-pad 8 :type (member 8 16 32)))    (scanline-pad 8 :type (member 8 16 32)))
250    
251  (defun print-pixmap-format (pixmap-format stream depth)  (defun print-pixmap-format (pixmap-format stream depth)
# Line 296  Line 300 
300    (roots nil :type list)                        ; List of screens    (roots nil :type list)                        ; List of screens
301    (motion-buffer-size 0 :type card32)           ; size of motion buffer    (motion-buffer-size 0 :type card32)           ; size of motion buffer
302    (xdefaults)                                   ; contents of defaults from server    (xdefaults)                                   ; contents of defaults from server
303    (image-lsb-first-p nil :type boolean)    (image-lsb-first-p nil :type generalized-boolean)
304    (bitmap-format (make-bitmap-format)           ; Screen image info    (bitmap-format (make-bitmap-format)           ; Screen image info
305                   :type bitmap-format)                   :type bitmap-format)
306    (pixmap-formats nil :type sequence)           ; list of pixmap formats    (pixmap-formats nil :type sequence)           ; list of pixmap formats
# Line 305  Line 309 
309    (error-handler 'default-error-handler)        ; Error handler function    (error-handler 'default-error-handler)        ; Error handler function
310    (close-down-mode :destroy)                    ; Close down mode saved by Set-Close-Down-Mode    (close-down-mode :destroy)                    ; Close down mode saved by Set-Close-Down-Mode
311    (authorization-name "" :type string)    (authorization-name "" :type string)
312    (authorization-data "" :type string)    (authorization-data "" :type (or (array (unsigned-byte 8)) string))
313    (last-width nil :type (or null card29))       ; Accumulated width of last string    (last-width nil :type (or null card29))       ; Accumulated width of last string
314    (keysym-mapping nil                           ; Keysym mapping cached from server    (keysym-mapping nil                           ; Keysym mapping cached from server
315                    :type (or null (array * (* *))))                    :type (or null (array * (* *))))
# Line 342  Line 346 
346    (atom-id-map (make-hash-table :test (resource-id-map-test)    (atom-id-map (make-hash-table :test (resource-id-map-test)
347                                  :size *atom-cache-size*)                                  :size *atom-cache-size*)
348                 :type hash-table)                 :type hash-table)
349      (extended-max-request-length 0 :type card32)
350    )    )
351    
352  (defun print-display-name (display stream)  (defun print-display-name (display stream)
# Line 380  Line 385 
385    (print-unreadable-object (drawable stream :type t)    (print-unreadable-object (drawable stream :type t)
386      (print-display-name (drawable-display drawable) stream)      (print-display-name (drawable-display drawable) stream)
387      (write-string " " stream)      (write-string " " stream)
388      (prin1 (drawable-id drawable) stream)))      (let ((*print-base* 16)) (prin1 (drawable-id drawable) stream))))
389    
390  (def-clx-class (window (:include drawable) (:copier nil)  (def-clx-class (window (:include drawable) (:copier nil)
391                         (:print-function print-drawable))                         (:print-function print-drawable))
# Line 450  Line 455 
455    
456  (deftype xatom () '(or string symbol))  (deftype xatom () '(or string symbol))
457    
458  (defconstant *predefined-atoms*  (defconstant +predefined-atoms+
459               '#(nil :PRIMARY :SECONDARY :ARC :ATOM :BITMAP   '#(nil :PRIMARY :SECONDARY :ARC :ATOM :BITMAP
460                      :CARDINAL :COLORMAP :CURSOR      :CARDINAL :COLORMAP :CURSOR
461                      :CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3      :CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3
462                      :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7      :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7
463                      :DRAWABLE :FONT :INTEGER :PIXMAP :POINT :RECTANGLE      :DRAWABLE :FONT :INTEGER :PIXMAP :POINT :RECTANGLE
464                      :RESOURCE_MANAGER :RGB_COLOR_MAP :RGB_BEST_MAP      :RESOURCE_MANAGER :RGB_COLOR_MAP :RGB_BEST_MAP
465                      :RGB_BLUE_MAP :RGB_DEFAULT_MAP      :RGB_BLUE_MAP :RGB_DEFAULT_MAP
466                      :RGB_GRAY_MAP :RGB_GREEN_MAP :RGB_RED_MAP :STRING      :RGB_GRAY_MAP :RGB_GREEN_MAP :RGB_RED_MAP :STRING
467                      :VISUALID :WINDOW :WM_COMMAND :WM_HINTS      :VISUALID :WINDOW :WM_COMMAND :WM_HINTS
468                      :WM_CLIENT_MACHINE :WM_ICON_NAME :WM_ICON_SIZE      :WM_CLIENT_MACHINE :WM_ICON_NAME :WM_ICON_SIZE
469                      :WM_NAME :WM_NORMAL_HINTS :WM_SIZE_HINTS      :WM_NAME :WM_NORMAL_HINTS :WM_SIZE_HINTS
470                      :WM_ZOOM_HINTS :MIN_SPACE :NORM_SPACE :MAX_SPACE      :WM_ZOOM_HINTS :MIN_SPACE :NORM_SPACE :MAX_SPACE
471                      :END_SPACE :SUPERSCRIPT_X :SUPERSCRIPT_Y      :END_SPACE :SUPERSCRIPT_X :SUPERSCRIPT_Y
472                      :SUBSCRIPT_X :SUBSCRIPT_Y      :SUBSCRIPT_X :SUBSCRIPT_Y
473                      :UNDERLINE_POSITION :UNDERLINE_THICKNESS      :UNDERLINE_POSITION :UNDERLINE_THICKNESS
474                      :STRIKEOUT_ASCENT :STRIKEOUT_DESCENT      :STRIKEOUT_ASCENT :STRIKEOUT_DESCENT
475                      :ITALIC_ANGLE :X_HEIGHT :QUAD_WIDTH :WEIGHT      :ITALIC_ANGLE :X_HEIGHT :QUAD_WIDTH :WEIGHT
476                      :POINT_SIZE :RESOLUTION :COPYRIGHT :NOTICE      :POINT_SIZE :RESOLUTION :COPYRIGHT :NOTICE
477                      :FONT_NAME :FAMILY_NAME :FULL_NAME :CAP_HEIGHT      :FONT_NAME :FAMILY_NAME :FULL_NAME :CAP_HEIGHT
478                      :WM_CLASS :WM_TRANSIENT_FOR))      :WM_CLASS :WM_TRANSIENT_FOR))
479    
480  (deftype stringable () '(or string symbol))  (deftype stringable () '(or string symbol))
481    
# Line 480  Line 485 
485    
486  (deftype timestamp () '(or null card32))  (deftype timestamp () '(or null card32))
487    
488  (defconstant *bit-gravity-vector*  (defconstant +bit-gravity-vector+
489               '#(:forget :north-west :north :north-east :west   '#(:forget :north-west :north :north-east :west
490                  :center :east :south-west :south      :center :east :south-west :south
491                  :south-east :static))      :south-east :static))
492    
493  (deftype bit-gravity ()  (deftype bit-gravity ()
494    '(member :forget :north-west :north :north-east :west    '(member :forget :north-west :north :north-east :west
495             :center :east :south-west :south :south-east :static))             :center :east :south-west :south :south-east :static))
496    
497  (defconstant *win-gravity-vector*  (defconstant +win-gravity-vector+
498               '#(:unmap :north-west :north :north-east :west   '#(:unmap :north-west :north :north-east :west
499                  :center :east :south-west :south :south-east      :center :east :south-west :south :south-east
500                  :static))      :static))
501    
502    (defparameter *protocol-families*
503      '(;; X11/X.h, Family*
504        (:internet . 0)
505        (:decnet . 1)
506        (:chaos . 2)
507        ;; X11/Xauth.h "not part of X standard"
508        (:Local . 256)
509        (:Wild . 65535)
510        (:Netname . 254)
511        (:Krb5Principal . 253)
512        (:LocalHost . 252)))
513    
514  (deftype win-gravity ()  (deftype win-gravity ()
515    '(member :unmap :north-west :north :north-east :west    '(member :unmap :north-west :north :north-east :west
# Line 532  Line 549 
549    (id 0 :type resource-id)    (id 0 :type resource-id)
550    (display nil :type (or null display))    (display nil :type (or null display))
551    (drawable nil :type (or null drawable))    (drawable nil :type (or null drawable))
552    (cache-p t :type boolean)    (cache-p t :type generalized-boolean)
553    (server-state (allocate-gcontext-state) :type gcontext-state)    (server-state (allocate-gcontext-state) :type gcontext-state)
554    (local-state (allocate-gcontext-state) :type gcontext-state)    (local-state (allocate-gcontext-state) :type gcontext-state)
555    (plist nil :type list)                        ; Extension hook    (plist nil :type list)                        ; Extension hook
# Line 547  Line 564 
564      (write-string " " stream)      (write-string " " stream)
565      (prin1 (gcontext-id gcontext) stream)))      (prin1 (gcontext-id gcontext) stream)))
566    
567  (defconstant *event-mask-vector*  (defconstant +event-mask-vector+
568               '#(:key-press :key-release :button-press :button-release   '#(:key-press :key-release :button-press :button-release
569                  :enter-window :leave-window :pointer-motion :pointer-motion-hint      :enter-window :leave-window :pointer-motion :pointer-motion-hint
570                  :button-1-motion :button-2-motion :button-3-motion :button-4-motion      :button-1-motion :button-2-motion :button-3-motion :button-4-motion
571                  :button-5-motion :button-motion :keymap-state :exposure :visibility-change      :button-5-motion :button-motion :keymap-state :exposure :visibility-change
572                  :structure-notify :resize-redirect :substructure-notify :substructure-redirect      :structure-notify :resize-redirect :substructure-notify :substructure-redirect
573                  :focus-change :property-change :colormap-change :owner-grab-button))      :focus-change :property-change :colormap-change :owner-grab-button))
574    
575  (deftype event-mask-class ()  (deftype event-mask-class ()
576    '(member :key-press :key-release :owner-grab-button :button-press :button-release    '(member :key-press :key-release :owner-grab-button :button-press :button-release
# Line 566  Line 583 
583  (deftype event-mask ()  (deftype event-mask ()
584    '(or mask32 (clx-list event-mask-class)))    '(or mask32 (clx-list event-mask-class)))
585    
586  (defconstant *pointer-event-mask-vector*  (defconstant +pointer-event-mask-vector+
587               '#(%error %error :button-press :button-release    ;; the first two elements used to be '%error '%error (i.e. symbols,
588                  :enter-window :leave-window :pointer-motion :pointer-motion-hint    ;; and not keywords) but the vector is supposed to contain
589                  :button-1-motion :button-2-motion :button-3-motion :button-4-motion    ;; keywords, so I renamed them -dan 2004.11.13
590                  :button-5-motion :button-motion :keymap-state))    '#(:%error :%error :button-press :button-release
591         :enter-window :leave-window :pointer-motion :pointer-motion-hint
592         :button-1-motion :button-2-motion :button-3-motion :button-4-motion
593         :button-5-motion :button-motion :keymap-state))
594    
595  (deftype pointer-event-mask-class ()  (deftype pointer-event-mask-class ()
596    '(member :button-press :button-release    '(member :button-press :button-release
# Line 581  Line 601 
601  (deftype pointer-event-mask ()  (deftype pointer-event-mask ()
602    '(or mask32 (clx-list pointer-event-mask-class)))    '(or mask32 (clx-list pointer-event-mask-class)))
603    
604  (defconstant *device-event-mask-vector*  (defconstant +device-event-mask-vector+
605               '#(:key-press :key-release :button-press :button-release :pointer-motion   '#(:key-press :key-release :button-press :button-release :pointer-motion
606                  :button-1-motion :button-2-motion :button-3-motion :button-4-motion      :button-1-motion :button-2-motion :button-3-motion :button-4-motion
607                  :button-5-motion :button-motion))      :button-5-motion :button-motion))
608    
609  (deftype device-event-mask-class ()  (deftype device-event-mask-class ()
610    '(member :key-press :key-release :button-press :button-release :pointer-motion    '(member :key-press :key-release :button-press :button-release :pointer-motion
# Line 594  Line 614 
614  (deftype device-event-mask ()  (deftype device-event-mask ()
615    '(or mask32 (clx-list device-event-mask-class)))    '(or mask32 (clx-list device-event-mask-class)))
616    
617  (defconstant *state-mask-vector*  (defconstant +state-mask-vector+
618               '#(:shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5   '#(:shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5
619                  :button-1 :button-2 :button-3 :button-4 :button-5))      :button-1 :button-2 :button-3 :button-4 :button-5))
620    
621  (deftype modifier-key ()  (deftype modifier-key ()
622    '(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5))    '(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5))
# Line 607  Line 627 
627  (deftype state-mask-key ()  (deftype state-mask-key ()
628    '(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5)))    '(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5)))
629    
630  (defconstant *gcontext-components*  (defconstant +gcontext-components+
631               '(:function :plane-mask :foreground :background   '(:function :plane-mask :foreground :background
632                 :line-width :line-style :cap-style :join-style :fill-style     :line-width :line-style :cap-style :join-style :fill-style
633                 :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode     :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode
634                 :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes     :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes
635                 :arc-mode))     :arc-mode))
636    
637  (deftype gcontext-key ()  (deftype gcontext-key ()
638    '(member :function :plane-mask :foreground :background    '(member :function :plane-mask :foreground :background
# Line 622  Line 642 
642             :arc-mode))             :arc-mode))
643    
644  (deftype event-key ()  (deftype event-key ()
645    '(member :key-press :key-release :button-press :button-release :motion-notify    '(or (member :key-press :key-release :button-press :button-release
646             :enter-notify :leave-notify :focus-in :focus-out :keymap-notify          :motion-notify :enter-notify :leave-notify :focus-in :focus-out
647             :exposure :graphics-exposure :no-exposure :visibility-notify          :keymap-notify :exposure :graphics-exposure :no-exposure
648             :create-notify :destroy-notify :unmap-notify :map-notify :map-request          :visibility-notify :create-notify :destroy-notify :unmap-notify
649             :reparent-notify :configure-notify :gravity-notify :resize-request          :map-notify :map-request :reparent-notify :configure-notify
650             :configure-request :circulate-notify :circulate-request :property-notify          :gravity-notify :resize-request :configure-request :circulate-notify
651             :selection-clear :selection-request :selection-notify          :circulate-request :property-notify :selection-clear
652             :colormap-notify :client-message :mapping-notify))          :selection-request :selection-notify :colormap-notify :client-message
653            :mapping-notify)
654           (satisfies extension-event-key-p)))
655    
656  (deftype error-key ()  (deftype error-key ()
657    '(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice    '(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice
# Line 638  Line 660 
660  (deftype draw-direction ()  (deftype draw-direction ()
661    '(member :left-to-right :right-to-left))    '(member :left-to-right :right-to-left))
662    
663  (defconstant *boole-vector*  (defconstant +boole-vector+
664               '#(#.boole-clr #.boole-and #.boole-andc2 #.boole-1   '#(#.boole-clr #.boole-and #.boole-andc2 #.boole-1
665                  #.boole-andc1 #.boole-2 #.boole-xor #.boole-ior      #.boole-andc1 #.boole-2 #.boole-xor #.boole-ior
666                  #.boole-nor #.boole-eqv #.boole-c2 #.boole-orc2      #.boole-nor #.boole-eqv #.boole-c2 #.boole-orc2
667                  #.boole-c1 #.boole-orc1 #.boole-nand #.boole-set))      #.boole-c1 #.boole-orc1 #.boole-nand #.boole-set))
668    
669  (deftype boole-constant ()  (deftype boole-constant ()
670    `(member ,boole-clr ,boole-and ,boole-andc2 ,boole-1    `(member ,boole-clr ,boole-and ,boole-andc2 ,boole-1
# Line 665  Line 687 
687    (min-installed-maps 1 :type card16)    (min-installed-maps 1 :type card16)
688    (max-installed-maps 1 :type card16)    (max-installed-maps 1 :type card16)
689    (backing-stores :never :type (member :never :when-mapped :always))    (backing-stores :never :type (member :never :when-mapped :always))
690    (save-unders-p nil :type boolean)    (save-unders-p nil :type generalized-boolean)
691    (event-mask-at-open 0 :type mask32)    (event-mask-at-open 0 :type mask32)
692    (plist nil :type list)                        ; Extension hook    (plist nil :type list)                        ; Extension hook
693    )    )
# Line 704  Line 726 
726    (max-byte1 0 :type card8)   ;; and specify min&max values for    (max-byte1 0 :type card8)   ;; and specify min&max values for
727    (min-byte2 0 :type card8)   ;; the two character bytes    (min-byte2 0 :type card8)   ;; the two character bytes
728    (max-byte2 0 :type card8)    (max-byte2 0 :type card8)
729    (all-chars-exist-p nil :type boolean)    (all-chars-exist-p nil :type generalized-boolean)
730    (default-char 0 :type card16)    (default-char 0 :type card16)
731    (min-bounds nil :type (or null vector))    (min-bounds nil :type (or null vector))
732    (max-bounds nil :type (or null vector))    (max-bounds nil :type (or null vector))
# Line 720  Line 742 
742    (name "" :type (or null string)) ;; NIL when ID is for a GContext    (name "" :type (or null string)) ;; NIL when ID is for a GContext
743    (font-info-internal nil :type (or null font-info))    (font-info-internal nil :type (or null font-info))
744    (char-infos-internal nil :type (or null (simple-array int16 (*))))    (char-infos-internal nil :type (or null (simple-array int16 (*))))
745    (local-only-p t :type boolean) ;; When T, always calculate text extents locally    (local-only-p t :type generalized-boolean) ;; When T, always calculate text extents locally
746    (plist nil :type list)                        ; Extension hook    (plist nil :type list)                        ; Extension hook
747    )    )
748    
# Line 792  Line 814 
814      (max-byte1 card8)      (max-byte1 card8)
815      (min-byte2 card8)      (min-byte2 card8)
816      (max-byte2 card8)      (max-byte2 card8)
817      (all-chars-exist-p boolean)      (all-chars-exist-p generalized-boolean)
818      (default-char card16)      (default-char card16)
819      (min-bounds vector)      (min-bounds vector)
820      (max-bounds vector)      (max-bounds vector)
# Line 807  Line 829 
829    (getf (font-properties font) name))    (getf (font-properties font) name))
830    
831  (macrolet ((make-mumble-equal (type)  (macrolet ((make-mumble-equal (type)
832               ;; When cached, EQ works fine, otherwise test resource id's and displays               ;; Since caching is only done for objects created by the
833                 ;; client, we must always compare ID and display for
834                 ;; non-identical mumbles.
835               (let ((predicate (xintern type '-equal))               (let ((predicate (xintern type '-equal))
836                     (id (xintern type '-id))                     (id (xintern type '-id))
837                     (dpy (xintern type '-display)))                     (dpy (xintern type '-display)))
838                 (if (member type *clx-cached-types*)                  `(within-definition (,type make-mumble-equal)
839                     `(within-definition (,type make-mumble-equal)                     (defun ,predicate (a b)
840                        (declaim (inline ,predicate))                       (declare (type ,type a b))
841                        (defun ,predicate (a b) (eq a b)))                       (or (eql a b)
842                     `(within-definition (,type make-mumble-equal)                           (and (= (,id a) (,id b))
843                        (defun ,predicate (a b)                                (eq (,dpy a) (,dpy b)))))))))
                         (declare (type ,type a b))  
                         (and (= (,id a) (,id b))  
                              (eq (,dpy a) (,dpy b)))))))))  
844    (make-mumble-equal window)    (make-mumble-equal window)
845    (make-mumble-equal pixmap)    (make-mumble-equal pixmap)
846    (make-mumble-equal cursor)    (make-mumble-equal cursor)
# Line 833  Line 854 
854  ;;;    Converts from keyword-lists to integer and back  ;;;    Converts from keyword-lists to integer and back
855  ;;;  ;;;
856  (defun encode-mask (key-vector key-list key-type)  (defun encode-mask (key-vector key-list key-type)
857    ;; KEY-VECTOR is a vector containg bit-position keywords.  The position of the    ;; KEY-VECTOR is a vector containg bit-position keywords.  The
858    ;; keyword in the vector indicates its bit position in the resulting mask    ;; position of the keyword in the vector indicates its bit position
859    ;; KEY-LIST is either a mask or a list of KEY-TYPE    ;; in the resulting mask.  KEY-LIST is either a mask or a list of
860    ;; Returns NIL when KEY-LIST is not a list or mask.    ;; KEY-TYPE Returns NIL when KEY-LIST is not a list or mask.
861    (declare (type (simple-array keyword (*)) key-vector)    (declare (type (simple-array keyword (*)) key-vector)
862             (type (or mask32 list) key-list))             (type (or mask32 list) key-list))
863    (declare (clx-values (or mask32 null)))    (declare (clx-values (or mask32 null)))
# Line 867  Line 888 
888  (defun encode-event-mask (event-mask)  (defun encode-event-mask (event-mask)
889    (declare (type event-mask event-mask))    (declare (type event-mask event-mask))
890    (declare (clx-values mask32))    (declare (clx-values mask32))
891    (or (encode-mask *event-mask-vector* event-mask 'event-mask-class)    (or (encode-mask +event-mask-vector+ event-mask 'event-mask-class)
892        (x-type-error event-mask 'event-mask)))        (x-type-error event-mask 'event-mask)))
893    
894  (defun make-event-mask (&rest keys)  (defun make-event-mask (&rest keys)
# Line 875  Line 896 
896    ;; Useful for constructing event-mask, pointer-event-mask, device-event-mask.    ;; Useful for constructing event-mask, pointer-event-mask, device-event-mask.
897    (declare (type (clx-list event-mask-class) keys))    (declare (type (clx-list event-mask-class) keys))
898    (declare (clx-values mask32))    (declare (clx-values mask32))
899    (encode-mask *event-mask-vector* keys 'event-mask-class))    (encode-mask +event-mask-vector+ keys 'event-mask-class))
900    
901  (defun make-event-keys (event-mask)  (defun make-event-keys (event-mask)
902    ;; This is only defined for core events.    ;; This is only defined for core events.
903    (declare (type mask32 event-mask))    (declare (type mask32 event-mask))
904    (declare (clx-values (clx-list event-mask-class)))    (declare (clx-values (clx-list event-mask-class)))
905    (decode-mask *event-mask-vector* event-mask))    (decode-mask +event-mask-vector+ event-mask))
906    
907  (defun encode-device-event-mask (device-event-mask)  (defun encode-device-event-mask (device-event-mask)
908    (declare (type device-event-mask device-event-mask))    (declare (type device-event-mask device-event-mask))
909    (declare (clx-values mask32))    (declare (clx-values mask32))
910    (or (encode-mask *device-event-mask-vector* device-event-mask    (or (encode-mask +device-event-mask-vector+ device-event-mask
911                     'device-event-mask-class)                     'device-event-mask-class)
912        (x-type-error device-event-mask 'device-event-mask)))        (x-type-error device-event-mask 'device-event-mask)))
913    
914  (defun encode-modifier-mask (modifier-mask)  (defun encode-modifier-mask (modifier-mask)
915    (declare (type modifier-mask modifier-mask))    (declare (type modifier-mask modifier-mask))
916    (declare (clx-values mask16))    (declare (clx-values mask16))
917    (or (encode-mask *state-mask-vector* modifier-mask 'modifier-key)    (or (and (eq modifier-mask :any) #x8000)
918        (and (eq modifier-mask :any) #x8000)        (encode-mask +state-mask-vector+ modifier-mask 'modifier-key)
919        (x-type-error modifier-mask 'modifier-mask)))        (x-type-error modifier-mask 'modifier-mask)))
920    
921  (defun encode-state-mask (state-mask)  (defun encode-state-mask (state-mask)
922    (declare (type (or mask16 (clx-list state-mask-key)) state-mask))    (declare (type (or mask16 (clx-list state-mask-key)) state-mask))
923    (declare (clx-values mask16))    (declare (clx-values mask16))
924    (or (encode-mask *state-mask-vector* state-mask 'state-mask-key)    (or (encode-mask +state-mask-vector+ state-mask 'state-mask-key)
925        (x-type-error state-mask '(or mask16 (clx-list state-mask-key)))))        (x-type-error state-mask '(or mask16 (clx-list state-mask-key)))))
926    
927  (defun make-state-mask (&rest keys)  (defun make-state-mask (&rest keys)
928    ;; Useful for constructing modifier-mask, state-mask.    ;; Useful for constructing modifier-mask, state-mask.
929    (declare (type (clx-list state-mask-key) keys))    (declare (type (clx-list state-mask-key) keys))
930    (declare (clx-values mask16))    (declare (clx-values mask16))
931    (encode-mask *state-mask-vector* keys 'state-mask-key))    (encode-mask +state-mask-vector+ keys 'state-mask-key))
932    
933  (defun make-state-keys (state-mask)  (defun make-state-keys (state-mask)
934    (declare (type mask16 state-mask))    (declare (type mask16 state-mask))
935    (declare (clx-values (clx-list state-mask-key)))    (declare (clx-values (clx-list state-mask-key)))
936    (decode-mask *state-mask-vector* state-mask))    (decode-mask +state-mask-vector+ state-mask))
937    
938  (defun encode-pointer-event-mask (pointer-event-mask)  (defun encode-pointer-event-mask (pointer-event-mask)
939    (declare (type pointer-event-mask pointer-event-mask))    (declare (type pointer-event-mask pointer-event-mask))
940    (declare (clx-values mask32))    (declare (clx-values mask32))
941    (or (encode-mask *pointer-event-mask-vector* pointer-event-mask    (or (encode-mask +pointer-event-mask-vector+ pointer-event-mask
942                     'pointer-event-mask-class)                     'pointer-event-mask-class)
943        (x-type-error pointer-event-mask 'pointer-event-mask)))        (x-type-error pointer-event-mask 'pointer-event-mask)))

Legend:
Removed from v.1.5.1.1  
changed lines
  Added in v.1.16

  ViewVC Help
Powered by ViewVC 1.1.5