home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / X / mit / lib / CLX / clx.l < prev    next >
Encoding:
Text File  |  1991-08-18  |  33.4 KB  |  905 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
  2.  
  3. ;;;
  4. ;;;             TEXAS INSTRUMENTS INCORPORATED
  5. ;;;                  P.O. BOX 2909
  6. ;;;                   AUSTIN, TEXAS 78769
  7. ;;;
  8. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  9. ;;;
  10. ;;; Permission is granted to any individual or institution to use, copy, modify,
  11. ;;; and distribute this software, provided that this complete copyright and
  12. ;;; permission notice is maintained, intact, in all copies and supporting
  13. ;;; documentation.
  14. ;;;
  15. ;;; Texas Instruments Incorporated provides this software "as is" without
  16. ;;; express or implied warranty.
  17. ;;;
  18.  
  19. ;; Primary Interface Author:
  20. ;;    Robert W. Scheifler
  21. ;;    MIT Laboratory for Computer Science
  22. ;;    545 Technology Square, Room 418
  23. ;;    Cambridge, MA 02139
  24. ;;    rws@zermatt.lcs.mit.edu
  25.  
  26. ;; Design Contributors:
  27. ;;    Dan Cerys, Texas Instruments
  28. ;;    Scott Fahlman, CMU
  29. ;;      Charles Hornig, Symbolics
  30. ;;      John Irwin, Franz
  31. ;;    Kerry Kimbrough, Texas Instruments
  32. ;;    Chris Lindblad, MIT
  33. ;;    Rob MacLachlan, CMU
  34. ;;    Mike McMahon, Symbolics
  35. ;;    David Moon, Symbolics
  36. ;;    LaMott Oren, Texas Instruments
  37. ;;    Daniel Weinreb, Symbolics
  38. ;;    John Wroclawski, MIT
  39. ;;    Richard Zippel, Symbolics
  40.  
  41. ;; Primary Implementation Author:
  42. ;;    LaMott Oren, Texas Instruments
  43.  
  44. ;; Implementation Contributors:
  45. ;;      Charles Hornig, Symbolics
  46. ;;      John Irwin, Franz
  47. ;;    Chris Lindblad, MIT
  48. ;;    Robert Scheifler, MIT
  49.  
  50. ;;;
  51. ;;; Change history:
  52. ;;;
  53. ;;;  Date    Author        Description
  54. ;;; -------------------------------------------------------------------------------------
  55. ;;; 04/07/87    R.Scheifler    Created code stubs
  56. ;;; 04/08/87    L.Oren        Started Implementation
  57. ;;; 05/11/87    L.Oren        Included draft 3 revisions
  58. ;;; 07/07/87    L.Oren        Untested alpha release to MIT
  59. ;;; 07/17/87    L.Oren        Alpha release
  60. ;;; 08/**/87    C.Lindblad    Rewrite of buffer code
  61. ;;; 08/**/87    et al        Various random bug fixes
  62. ;;; 08/**/87    R.Scheifler    General syntactic and portability cleanups
  63. ;;; 08/**/87    R.Scheifler    Rewrite of gcontext caching and shadowing
  64. ;;; 09/02/87    L.Oren        Change events from resource-ids to objects
  65. ;;; 12/24/87    R.Budzianowski    KCL support
  66. ;;; 12/**/87    J.Irwin        ExCL 2.0 support
  67. ;;; 01/20/88    L.Oren        Add server extension mechanisms
  68. ;;; 01/20/88    L.Oren        Only force output when blocking on input
  69. ;;; 01/20/88    L.Oren        Uniform support for :event-window on events
  70. ;;; 01/28/88    L.Oren        Add window manager property functions
  71. ;;; 01/28/88    L.Oren        Add character translation facility
  72. ;;; 02/**/87    J.Irwin        Allegro 2.2 support
  73.  
  74. ;;; This is considered a somewhat changeable interface.  Discussion of better
  75. ;;; integration with CLOS, support for user-specified subclassess of basic
  76. ;;; 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.
  78.  
  79. ;; Note: all of the following is in the package XLIB.
  80.  
  81. (in-package :xlib)
  82.  
  83. (pushnew :clx *features*)
  84. (pushnew :xlib *features*)
  85.  
  86. (defparameter *version* "MIT R5.0")
  87. (pushnew :clx-mit-r4 *features*)
  88. (pushnew :clx-mit-r5 *features*)
  89.  
  90. (defparameter *protocol-major-version* 11.)
  91. (defparameter *protocol-minor-version* 0)
  92.  
  93. (defparameter *x-tcp-port* 6000) ;; add display number
  94.  
  95. ; Note: various perversions of the CL type system are used below.
  96. ; Examples: (list elt-type) (sequence elt-type)
  97.  
  98. ;; Note: if you have read the Version 11 protocol document or C Xlib manual, most of
  99. ;; the relationships should be fairly obvious.  We have no intention of writing yet
  100. ;; another moby document for this interface.
  101.  
  102. ;; Types employed: display, window, pixmap, cursor, font, gcontext, colormap, color.
  103. ;; These types are defined solely by a functional interface; we do not specify
  104. ;; whether they are implemented as structures or flavors or ...  Although functions
  105. ;; below are written using DEFUN, this is not an implementation requirement (although
  106. ;; it is a requirement that they be functions as opposed to macros or special forms).
  107. ;; It is unclear whether with-slots in the Common Lisp Object System must work on
  108. ;; them.
  109.  
  110. ;; Windows, pixmaps, cursors, fonts, gcontexts, and colormaps are all represented as
  111. ;; compound objects, rather than as integer resource-ids.  This allows applications
  112. ;; to deal with multiple displays without having an explicit display argument in the
  113. ;; most common functions.  Every function uses the display object indicated by the
  114. ;; first argument that is or contains a display; it is an error if arguments contain
  115. ;; different displays, and predictable results are not guaranteed.
  116.  
  117. ;; Each of window, pixmap, cursor, font, gcontext, and colormap have the following
  118. ;; five functions:
  119.  
  120. ;(defun make-<mumble> (display resource-id)
  121. ;  ;; This function should almost never be called by applications, except in handling
  122. ;  ;; events.  To minimize consing in some implementations, this may use a cache in
  123. ;  ;; the display.  Make-gcontext creates with :cache-p nil.  Make-font creates with
  124. ;  ;; cache-p true.
  125. ;  (declare (type display display)
  126. ;       (type integer resource-id)
  127. ;       (values <mumble>)))
  128.  
  129. ;(defun <mumble>-display (<mumble>)
  130. ;  (declare (type <mumble> <mumble>)
  131. ;       (values display)))
  132.  
  133. ;(defun <mumble>-id (<mumble>)
  134. ;  (declare (type <mumble> <mumble>)
  135. ;       (values integer)))
  136.  
  137. ;(defun <mumble>-equal (<mumble>-1 <mumble>-2)
  138. ;  (declare (type <mumble> <mumble>-1 <mumble>-2)))
  139.  
  140. ;(defun <mumble>-p (<mumble>-1 <mumble>-2)
  141. ;  (declare (type <mumble> <mumble>-1 <mumble>-2)
  142. ;       (values boolean)))
  143.  
  144. (deftype boolean () '(or null (not null)))
  145.  
  146. (deftype card32 () '(unsigned-byte 32))
  147.  
  148. (deftype card29 () '(unsigned-byte 29))
  149.  
  150. (deftype card24 () '(unsigned-byte 24))
  151.  
  152. (deftype int32 () '(signed-byte 32))
  153.  
  154. (deftype card16 () '(unsigned-byte 16))
  155.  
  156. (deftype int16 () '(signed-byte 16))
  157.  
  158. (deftype card8 () '(unsigned-byte 8))
  159.  
  160. (deftype int8 () '(signed-byte 8))
  161.  
  162. (deftype card4 () '(unsigned-byte 4))
  163.  
  164. #-clx-ansi-common-lisp
  165. (deftype real (&optional (min '*) (max '*))
  166.   (labels ((convert (limit floatp)
  167.          (typecase limit
  168.            (number (if floatp (float limit 0s0) (rational limit)))
  169.            (list (map 'list #'convert limit))
  170.            (otherwise limit))))
  171.     `(or (float ,(convert min t) ,(convert max t))
  172.      (rational ,(convert min nil) ,(convert max nil)))))
  173.  
  174. #-clx-ansi-common-lisp
  175. (deftype base-char ()
  176.   'string-char)
  177.  
  178. ; Note that we are explicitly using a different rgb representation than what
  179. ; is actually transmitted in the protocol.
  180.  
  181. (deftype rgb-val () '(real 0 1))
  182.  
  183. ; Note that we are explicitly using a different angle representation than what
  184. ; is actually transmitted in the protocol.
  185.  
  186. (deftype angle () '(real #.(* -2 pi) #.(* 2 pi)))
  187.  
  188. (deftype mask32 () 'card32)
  189.  
  190. (deftype mask16 () 'card16)
  191.  
  192. (deftype pixel () '(unsigned-byte 32))
  193. (deftype image-depth () '(integer 0 32))
  194.  
  195. (deftype resource-id () 'card29)
  196.  
  197. (deftype keysym () 'card32)
  198.  
  199. ; The following functions are provided by color objects:
  200.  
  201. ; The intention is that IHS and YIQ and CYM interfaces will also exist.
  202. ; Note that we are explicitly using a different spectrum representation
  203. ; than what is actually transmitted in the protocol.
  204.  
  205. (def-clx-class (color (:constructor make-color-internal (red green blue))
  206.               (:copier nil) (:print-function print-color))
  207.   (red 0.0 :type rgb-val)
  208.   (green 0.0 :type rgb-val)
  209.   (blue 0.0 :type rgb-val))
  210.  
  211. (defun print-color (color stream depth)
  212.   (declare (type color color)
  213.        (ignore depth))
  214.   (print-unreadable-object (color stream :type t)
  215.     (prin1 (color-red color) stream)
  216.     (write-string " " stream)
  217.     (prin1 (color-green color) stream)
  218.     (write-string " " stream)
  219.     (prin1 (color-blue color) stream)))
  220.  
  221. (defun make-color (&key (red 1.0) (green 1.0) (blue 1.0) &allow-other-keys)
  222.   (declare (type rgb-val red green blue))
  223.   (declare (values color))
  224.   (make-color-internal red green blue))
  225.  
  226. (defun color-rgb (color)
  227.   (declare (type color color))
  228.   (declare (values red green blue))
  229.   (values (color-red color) (color-green color) (color-blue color)))
  230.  
  231. (def-clx-class (bitmap-format (:copier nil))
  232.   (unit 8 :type (member 8 16 32))
  233.   (pad 8 :type (member 8 16 32))
  234.   (lsb-first-p nil :type boolean))
  235.  
  236. (def-clx-class (pixmap-format (:copier nil))
  237.   (depth 0 :type image-depth)
  238.   (bits-per-pixel 8 :type (member 1 4 8 16 24 32))
  239.   (scanline-pad 8 :type (member 8 16 32)))
  240.  
  241. (defparameter *atom-cache-size* 200)
  242. (defparameter *resource-id-map-size* 500)
  243.  
  244. (def-clx-class (display (:include buffer)
  245.             (:constructor make-display-internal)
  246.             (:print-function print-display)
  247.             (:copier nil))
  248.   (host)                    ; Server Host
  249.   (display 0 :type integer)            ; Display number on host
  250.   (after-function nil)                ; Function to call after every request
  251.   (event-lock
  252.     (make-process-lock "CLX Event Lock"))    ; with-event-queue lock
  253.   (event-queue-lock
  254.     (make-process-lock "CLX Event Queue Lock"))    ; new-events/event-queue lock
  255.   (event-queue-tail                ; last event in the event queue
  256.     nil :type (or null reply-buffer))
  257.   (event-queue-head                ; Threaded queue of events
  258.     nil :type (or null reply-buffer))
  259.   (atom-cache (make-hash-table :test (atom-cache-map-test) :size *atom-cache-size*)
  260.           :type hash-table)            ; Hash table relating atoms keywords
  261.                         ; to atom id's
  262.   (font-cache nil)                ; list of font
  263.   (protocol-major-version 0 :type card16)    ; Major version of server's X protocol
  264.   (protocol-minor-version 0 :type card16)    ; minor version of servers X protocol
  265.   (vendor-name "" :type string)            ; vendor of the server hardware
  266.   (resource-id-base 0 :type resource-id)    ; resouce ID base
  267.   (resource-id-mask 0 :type resource-id)    ; resource ID mask bits
  268.   (resource-id-byte nil)            ; resource ID mask field (used with DPB & LDB)
  269.   (resource-id-count 0 :type resource-id)    ; resource ID mask count
  270.                         ; (used for allocating ID's)
  271.   (resource-id-map (make-hash-table :test (resource-id-map-test)
  272.                     :size *resource-id-map-size*)
  273.            :type hash-table)        ; hash table maps resource-id's to
  274.                         ; objects (used in lookup functions)
  275.   (xid 'resourcealloc)                ; allocator function
  276.   (byte-order #+clx-little-endian :lsbfirst     ; connection byte order
  277.           #-clx-little-endian :msbfirst)
  278.   (release-number 0 :type card32)        ; release of the server
  279.   (max-request-length 0 :type card16)        ; maximum number 32 bit words in request
  280.   (default-screen)                ; default screen for operations
  281.   (roots nil :type list)            ; List of screens
  282.   (motion-buffer-size 0 :type card32)        ; size of motion buffer
  283.   (xdefaults)                    ; contents of defaults from server
  284.   (image-lsb-first-p nil :type boolean)
  285.   (bitmap-format (make-bitmap-format)        ; Screen image info
  286.          :type bitmap-format)
  287.   (pixmap-formats nil :type sequence)        ; list of pixmap formats
  288.   (min-keycode 0 :type card8)            ; minimum key-code
  289.   (max-keycode 0 :type card8)            ; maximum key-code
  290.   (error-handler 'default-error-handler)    ; Error handler function
  291.   (close-down-mode :destroy)              ; Close down mode saved by Set-Close-Down-Mode
  292.   (authorization-name "" :type string)
  293.   (authorization-data "" :type string)
  294.   (last-width nil :type (or null card29))    ; Accumulated width of last string
  295.   (keysym-mapping nil                ; Keysym mapping cached from server
  296.           :type (or null (array * (* *))))
  297.   (modifier-mapping nil :type list)        ; ALIST of (keysym . state-mask) for all modifier keysyms
  298.   (keysym-translation nil :type list)        ; An alist of (keysym object function)
  299.                         ; for display-local keysyms
  300.   (extension-alist nil :type list)        ; extension alist, which has elements:
  301.                         ; (name major-opcode first-event first-error)
  302.   (event-extensions '#() :type vector)        ; Vector mapping X event-codes to event keys
  303.   (performance-info)                ; Hook for gathering performance info
  304.   (trace-history)                ; Hook for debug trace
  305.   (plist)                    ; hook for extension to hang data
  306.   ;; These slots are used to manage multi-process input.
  307.   (input-in-progress nil)            ; Some process reading from the stream.
  308.                         ; Updated with CONDITIONAL-STORE.
  309.   (pending-commands nil)            ; Threaded list of PENDING-COMMAND objects 
  310.                         ; for all commands awaiting replies.
  311.                         ; Protected by WITH-EVENT-QUEUE-INTERNAL.
  312.   (asynchronous-errors nil)            ; Threaded list of REPLY-BUFFER objects
  313.                         ; containing error messages for commands
  314.                         ; which did not expect replies.
  315.                         ; Protected by WITH-EVENT-QUEUE-INTERNAL.
  316.   (report-asynchronous-errors            ; When to report asynchronous errors
  317.     '(:immediately) :type list)            ; The keywords that can be on this list 
  318.                         ; are :IMMEDIATELY, :BEFORE-EVENT-HANDLING,
  319.                         ; and :AFTER-FINISH-OUTPUT
  320.   (event-process nil)                ; Process ID of process awaiting events.
  321.                         ; Protected by WITH-EVENT-QUEUE.
  322.   (new-events nil :type (or null reply-buffer))    ; Pointer to the first new event in the
  323.                         ; event queue.
  324.                         ; Protected by WITH-EVENT-QUEUE.
  325.   (current-event-symbol                ; Bound with PROGV by event handling macros 
  326.     (list (gensym) (gensym)) :type cons)
  327.   (atom-id-map (make-hash-table :test (resource-id-map-test)
  328.                 :size *atom-cache-size*)
  329.            :type hash-table)
  330.   )
  331.  
  332. (defun print-display-name (display stream)
  333.   (declare (type (or null display) display))
  334.   (cond (display
  335.      #-allegro (princ (display-host display) stream)
  336.      #+allegro (write-string (string (display-host display)) stream)
  337.      (write-string ":" stream)
  338.      (princ (display-display display) stream))
  339.     (t
  340.      (write-string "(no display)" stream)))
  341.   display)
  342.  
  343. (defun print-display (display stream depth)
  344.   (declare (type display display)
  345.        (ignore depth))
  346.   (print-unreadable-object (display stream :type t)
  347.     (print-display-name display stream)
  348.     (write-string " (" stream)
  349.     (write-string (display-vendor-name display) stream)
  350.     (write-string " R" stream)
  351.     (prin1 (display-release-number display) stream)
  352.     (write-string ")" stream)))
  353.  
  354. ;;(deftype drawable () '(or window pixmap))
  355.  
  356. (def-clx-class (drawable (:copier nil) (:print-function print-drawable))
  357.   (id 0 :type resource-id)
  358.   (display nil :type (or null display))
  359.   (plist nil :type list)            ; Extension hook
  360.   )
  361.  
  362. (defun print-drawable (drawable stream depth)
  363.   (declare (type drawable drawable)
  364.        (ignore depth))
  365.   (print-unreadable-object (drawable stream :type t)
  366.     (print-display-name (drawable-display drawable) stream)
  367.     (write-string " " stream)
  368.     (prin1 (drawable-id drawable) stream)))
  369.  
  370. (def-clx-class (window (:include drawable) (:copier nil)
  371.                (:print-function print-drawable))
  372.   )
  373.  
  374. (def-clx-class (pixmap (:include drawable) (:copier nil)
  375.                (:print-function print-drawable))
  376.   )
  377.  
  378. (def-clx-class (visual-info (:copier nil) (:print-function print-visual-info))
  379.   (id 0 :type resource-id)
  380.   (display nil :type (or null display))
  381.   (class :static-gray :type (member :static-gray :static-color :true-color
  382.                     :gray-scale :pseudo-color :direct-color))
  383.   (red-mask 0 :type pixel)
  384.   (green-mask 0 :type pixel)
  385.   (blue-mask 0 :type pixel)
  386.   (bits-per-rgb 1 :type card8)
  387.   (colormap-entries 0 :type card16)
  388.   (plist nil :type list)            ; Extension hook
  389.   )
  390.  
  391. (defun print-visual-info (visual-info stream depth)
  392.   (declare (type visual-info visual-info)
  393.        (ignore depth))
  394.   (print-unreadable-object (visual-info stream :type t)
  395.     (prin1 (visual-info-bits-per-rgb visual-info) stream)
  396.     (write-string "-bit " stream)
  397.     (princ (visual-info-class visual-info) stream)
  398.     (write-string " " stream)
  399.     (print-display-name (visual-info-display visual-info) stream)
  400.     (write-string " " stream)
  401.     (prin1 (visual-info-id visual-info) stream)))
  402.  
  403. (def-clx-class (colormap (:copier nil) (:print-function print-colormap))
  404.   (id 0 :type resource-id)
  405.   (display nil :type (or null display))
  406.   (visual-info nil :type (or null visual-info))
  407.   )
  408.  
  409. (defun print-colormap (colormap stream depth)
  410.   (declare (type colormap colormap)
  411.        (ignore depth))
  412.   (print-unreadable-object (colormap stream :type t)
  413.     (when (colormap-visual-info colormap)
  414.       (princ (visual-info-class (colormap-visual-info colormap)) stream)
  415.       (write-string " " stream))
  416.     (print-display-name (colormap-display colormap) stream)
  417.     (write-string " " stream)
  418.     (prin1 (colormap-id colormap) stream)))
  419.  
  420. (def-clx-class (cursor (:copier nil) (:print-function print-cursor))
  421.   (id 0 :type resource-id)
  422.   (display nil :type (or null display))
  423.   )
  424.  
  425. (defun print-cursor (cursor stream depth)
  426.   (declare (type cursor cursor)
  427.        (ignore depth))
  428.   (print-unreadable-object (cursor stream :type t)
  429.     (print-display-name (cursor-display cursor) stream)
  430.     (write-string " " stream)
  431.     (prin1 (cursor-id cursor) stream)))
  432.  
  433. ; Atoms are accepted as strings or symbols, and are always returned as keywords.
  434. ; Protocol-level integer atom ids are hidden, using a cache in the display object.
  435.  
  436. (deftype xatom () '(or string symbol))
  437.  
  438. (defconstant *predefined-atoms*
  439.          '#(nil :PRIMARY :SECONDARY :ARC :ATOM :BITMAP
  440.             :CARDINAL :COLORMAP :CURSOR
  441.             :CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3
  442.             :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7
  443.             :DRAWABLE :FONT :INTEGER :PIXMAP :POINT :RECTANGLE
  444.             :RESOURCE_MANAGER :RGB_COLOR_MAP :RGB_BEST_MAP
  445.             :RGB_BLUE_MAP :RGB_DEFAULT_MAP
  446.             :RGB_GRAY_MAP :RGB_GREEN_MAP :RGB_RED_MAP :STRING
  447.             :VISUALID :WINDOW :WM_COMMAND :WM_HINTS
  448.             :WM_CLIENT_MACHINE :WM_ICON_NAME :WM_ICON_SIZE
  449.             :WM_NAME :WM_NORMAL_HINTS :WM_SIZE_HINTS
  450.             :WM_ZOOM_HINTS :MIN_SPACE :NORM_SPACE :MAX_SPACE
  451.             :END_SPACE :SUPERSCRIPT_X :SUPERSCRIPT_Y
  452.             :SUBSCRIPT_X :SUBSCRIPT_Y
  453.             :UNDERLINE_POSITION :UNDERLINE_THICKNESS
  454.             :STRIKEOUT_ASCENT :STRIKEOUT_DESCENT
  455.             :ITALIC_ANGLE :X_HEIGHT :QUAD_WIDTH :WEIGHT
  456.             :POINT_SIZE :RESOLUTION :COPYRIGHT :NOTICE
  457.             :FONT_NAME :FAMILY_NAME :FULL_NAME :CAP_HEIGHT
  458.             :WM_CLASS :WM_TRANSIENT_FOR))
  459.  
  460. (deftype stringable () '(or string symbol))
  461.  
  462. (deftype fontable () '(or stringable font))
  463.  
  464. ; Nil stands for CurrentTime.
  465.  
  466. (deftype timestamp () '(or null card32))
  467.  
  468. (defconstant *bit-gravity-vector*
  469.          '#(:forget :north-west :north :north-east :west
  470.         :center :east :south-west :south
  471.         :south-east :static))
  472.  
  473. (deftype bit-gravity ()
  474.   '(member :forget :north-west :north :north-east :west
  475.        :center :east :south-west :south :south-east :static))
  476.  
  477. (defconstant *win-gravity-vector*
  478.          '#(:unmap :north-west :north :north-east :west
  479.         :center :east :south-west :south :south-east
  480.         :static))
  481.  
  482. (deftype win-gravity ()
  483.   '(member :unmap :north-west :north :north-east :west
  484.        :center :east :south-west :south :south-east :static))
  485.  
  486. (deftype grab-status ()
  487.   '(member :success :already-grabbed :invalid-time :not-viewable))
  488.  
  489. ; An association list.
  490.  
  491. (deftype alist (key-type-and-name datum-type-and-name)
  492.   (declare (ignore key-type-and-name datum-type-and-name))
  493.   'list)
  494.  
  495. ; A sequence, containing zero or more repetitions of the given elements,
  496. ; with the elements expressed as (type name).
  497.  
  498. (deftype repeat-seq (&rest elts) elts 'sequence)
  499.  
  500. (deftype point-seq () '(repeat-seq (int16 x) (int16 y)))
  501.  
  502. (deftype seg-seq () '(repeat-seq (int16 x1) (int16 y1) (int16 x2) (int16 y2)))
  503.  
  504. (deftype rect-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)))
  505.  
  506. (deftype arc-seq ()
  507.   '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)
  508.            (angle angle1) (angle angle2)))
  509.  
  510. (deftype gcontext-state () 'simple-vector)
  511.  
  512. (def-clx-class (gcontext (:copier nil) (:print-function print-gcontext))
  513.   ;; The accessors convert to CLX data types.
  514.   (id 0 :type resource-id)
  515.   (display nil :type (or null display))
  516.   (drawable nil :type (or null drawable))
  517.   (cache-p t :type boolean)
  518.   (server-state (allocate-gcontext-state) :type gcontext-state)
  519.   (local-state (allocate-gcontext-state) :type gcontext-state)
  520.   (plist nil :type list)            ; Extension hook
  521.   (next nil #-explorer :type #-explorer (or null gcontext))
  522.   )
  523.  
  524. (defun print-gcontext (gcontext stream depth)
  525.   (declare (type gcontext gcontext)
  526.        (ignore depth))
  527.   (print-unreadable-object (gcontext stream :type t)
  528.     (print-display-name (gcontext-display gcontext) stream)
  529.     (write-string " " stream)
  530.     (prin1 (gcontext-id gcontext) stream)))
  531.  
  532. (defconstant *event-mask-vector*
  533.          '#(:key-press :key-release :button-press :button-release
  534.         :enter-window :leave-window :pointer-motion :pointer-motion-hint
  535.         :button-1-motion :button-2-motion :button-3-motion :button-4-motion
  536.         :button-5-motion :button-motion :keymap-state :exposure :visibility-change
  537.         :structure-notify :resize-redirect :substructure-notify :substructure-redirect
  538.         :focus-change :property-change :colormap-change :owner-grab-button))
  539.  
  540. (deftype event-mask-class ()
  541.   '(member :key-press :key-release :owner-grab-button :button-press :button-release
  542.        :enter-window :leave-window :pointer-motion :pointer-motion-hint
  543.        :button-1-motion :button-2-motion :button-3-motion :button-4-motion
  544.        :button-5-motion :button-motion :exposure :visibility-change
  545.        :structure-notify :resize-redirect :substructure-notify :substructure-redirect
  546.        :focus-change :property-change :colormap-change :keymap-state))
  547.  
  548. (deftype event-mask ()
  549.   '(or mask32 list)) ;; (OR integer (LIST event-mask-class))
  550.  
  551. (defconstant *pointer-event-mask-vector*
  552.          '#(%error %error :button-press :button-release
  553.         :enter-window :leave-window :pointer-motion :pointer-motion-hint
  554.         :button-1-motion :button-2-motion :button-3-motion :button-4-motion
  555.         :button-5-motion :button-motion :keymap-state))
  556.  
  557. (deftype pointer-event-mask-class ()
  558.   '(member :button-press :button-release
  559.        :enter-window :leave-window :pointer-motion :pointer-motion-hint
  560.        :button-1-motion :button-2-motion :button-3-motion :button-4-motion
  561.        :button-5-motion :button-motion :keymap-state))
  562.  
  563. (deftype pointer-event-mask ()
  564.   '(or mask32 list)) ;;  '(or integer (list pointer-event-mask-class)))
  565.  
  566. (defconstant *device-event-mask-vector*
  567.          '#(:key-press :key-release :button-press :button-release :pointer-motion
  568.         :button-1-motion :button-2-motion :button-3-motion :button-4-motion
  569.         :button-5-motion :button-motion))
  570.  
  571. (deftype device-event-mask-class ()
  572.   '(member :key-press :key-release :button-press :button-release :pointer-motion
  573.        :button-1-motion :button-2-motion :button-3-motion :button-4-motion
  574.        :button-5-motion :button-motion))
  575.  
  576. (deftype device-event-mask ()
  577.   '(or mask32 list)) ;;  '(or integer (list device-event-mask-class)))
  578.  
  579. (defconstant *state-mask-vector*
  580.          '#(:shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5
  581.         :button-1 :button-2 :button-3 :button-4 :button-5))
  582.  
  583. (deftype modifier-key ()
  584.   '(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5))
  585.  
  586. (deftype modifier-mask ()
  587.   '(or (member :any) mask16 list)) ;;  '(or (member :any) integer (list modifier-key)))
  588.  
  589. (deftype state-mask-key ()
  590.   '(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5)))
  591.  
  592. (defconstant *gcontext-components*
  593.          '(:function :plane-mask :foreground :background
  594.            :line-width :line-style :cap-style :join-style :fill-style
  595.            :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode
  596.            :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes
  597.            :arc-mode))
  598.  
  599. (deftype gcontext-key ()
  600.   '(member :function :plane-mask :foreground :background
  601.        :line-width :line-style :cap-style :join-style :fill-style
  602.        :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode
  603.        :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes
  604.        :arc-mode))
  605.  
  606. (deftype event-key ()
  607.   '(member :key-press :key-release :button-press :button-release :motion-notify
  608.        :enter-notify :leave-notify :focus-in :focus-out :keymap-notify
  609.        :exposure :graphics-exposure :no-exposure :visibility-notify
  610.        :create-notify :destroy-notify :unmap-notify :map-notify :map-request
  611.        :reparent-notify :configure-notify :gravity-notify :resize-request
  612.        :configure-request :circulate-notify :circulate-request :property-notify
  613.        :selection-clear :selection-request :selection-notify
  614.        :colormap-notify :client-message :mapping-notify))
  615.  
  616. (deftype error-key ()
  617.   '(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice
  618.        :illegal-request :implementation :length :match :name :pixmap :value :window))
  619.  
  620. (deftype draw-direction ()
  621.   '(member :left-to-right :right-to-left))
  622.  
  623. (defconstant *boole-vector*
  624.          '#(#.boole-clr #.boole-and #.boole-andc2 #.boole-1
  625.         #.boole-andc1 #.boole-2 #.boole-xor #.boole-ior
  626.         #.boole-nor #.boole-eqv #.boole-c2 #.boole-orc2
  627.         #.boole-c1 #.boole-orc1 #.boole-nand #.boole-set))
  628.  
  629. (deftype boole-constant ()
  630.   `(member ,boole-clr ,boole-and ,boole-andc2 ,boole-1
  631.        ,boole-andc1 ,boole-2 ,boole-xor ,boole-ior
  632.        ,boole-nor ,boole-eqv ,boole-c2 ,boole-orc2
  633.        ,boole-c1 ,boole-orc1 ,boole-nand ,boole-set))
  634.  
  635. (def-clx-class (screen (:copier nil) (:print-function print-screen))
  636.   (root nil :type (or null window))
  637.   (width 0 :type card16)
  638.   (height 0 :type card16)
  639.   (width-in-millimeters 0 :type card16)
  640.   (height-in-millimeters 0 :type card16)
  641.   (depths nil :type (alist (image-depth depth) ((list visual-info) visuals)))
  642.   (root-depth 1 :type image-depth)
  643.   (root-visual-info nil :type (or null visual-info))
  644.   (default-colormap nil :type (or null colormap))
  645.   (white-pixel 0 :type pixel)
  646.   (black-pixel 1 :type pixel)
  647.   (min-installed-maps 1 :type card16)
  648.   (max-installed-maps 1 :type card16)
  649.   (backing-stores :never :type (member :never :when-mapped :always))
  650.   (save-unders-p nil :type boolean)
  651.   (event-mask-at-open 0 :type mask32)
  652.   (plist nil :type list)            ; Extension hook
  653.   )
  654.  
  655. (defun print-screen (screen stream depth)
  656.   (declare (type screen screen)
  657.        (ignore depth))
  658.   (print-unreadable-object (screen stream :type t)
  659.     (let ((display (drawable-display (screen-root screen))))
  660.       (print-display-name display stream)
  661.       (write-string "." stream)
  662.       (princ (position screen (display-roots display)) stream))
  663.     (write-string " " stream)
  664.     (prin1 (screen-width screen) stream)
  665.     (write-string "x" stream)
  666.     (prin1 (screen-height screen) stream)
  667.     (write-string "x" stream)
  668.     (prin1 (screen-root-depth screen) stream)
  669.     (when (screen-root-visual-info screen)
  670.       (write-string " " stream)
  671.       (princ (visual-info-class (screen-root-visual-info screen)) stream))))
  672.  
  673. (defun screen-root-visual (screen)
  674.   (declare (type screen screen)
  675.        (values resource-id))
  676.   (visual-info-id (screen-root-visual-info screen)))
  677.  
  678. ;; The list contains alternating keywords and integers.
  679. (deftype font-props () 'list)
  680.  
  681. (def-clx-class (font-info (:copier nil) (:predicate nil))
  682.   (direction :left-to-right :type draw-direction)
  683.   (min-char 0 :type card16)   ;; First character in font
  684.   (max-char 0 :type card16)   ;; Last character in font
  685.   (min-byte1 0 :type card8)   ;; The following are for 16 bit fonts
  686.   (max-byte1 0 :type card8)   ;; and specify min&max values for
  687.   (min-byte2 0 :type card8)   ;; the two character bytes
  688.   (max-byte2 0 :type card8)
  689.   (all-chars-exist-p nil :type boolean)
  690.   (default-char 0 :type card16)
  691.   (min-bounds nil :type (or null vector))
  692.   (max-bounds nil :type (or null vector))
  693.   (ascent 0 :type int16)
  694.   (descent 0 :type int16)
  695.   (properties nil :type font-props))
  696.  
  697. (def-clx-class (font (:constructor make-font-internal) (:copier nil)
  698.              (:print-function print-font))
  699.   (id-internal nil :type (or null resource-id)) ;; NIL when not opened
  700.   (display nil :type (or null display))
  701.   (reference-count 0 :type fixnum)
  702.   (name "" :type (or null string)) ;; NIL when ID is for a GContext
  703.   (font-info-internal nil :type (or null font-info))
  704.   (char-infos-internal nil :type (or null (simple-array int16 (*))))
  705.   (local-only-p t :type boolean) ;; When T, always calculate text extents locally
  706.   (plist nil :type list)            ; Extension hook
  707.   )
  708.  
  709. (defun print-font (font stream depth)
  710.   (declare (type font font)
  711.        (ignore depth))
  712.   (print-unreadable-object (font stream :type t)
  713.     (if (font-name font)
  714.     (princ (font-name font) stream)
  715.       (write-string "(gcontext)" stream))
  716.     (write-string " " stream)
  717.     (print-display-name (font-display font) stream)
  718.     (when (font-id-internal font)
  719.       (write-string " " stream)
  720.       (prin1 (font-id font) stream))))
  721.  
  722. (defun font-id (font)
  723.   ;; Get font-id, opening font if needed
  724.   (or (font-id-internal font)
  725.       (open-font-internal font)))
  726.  
  727. (defun font-font-info (font)
  728.   (or (font-font-info-internal font)
  729.       (query-font font)))
  730.  
  731. (defun font-char-infos (font)
  732.   (or (font-char-infos-internal font)
  733.       (progn (query-font font)
  734.          (font-char-infos-internal font))))
  735.  
  736. (defun make-font (&key id
  737.           display
  738.           (reference-count 0)
  739.           (name "")
  740.           (local-only-p t)
  741.           font-info-internal)
  742.   (make-font-internal :id-internal id
  743.               :display display
  744.               :reference-count reference-count
  745.               :name name
  746.               :local-only-p local-only-p
  747.               :font-info-internal font-info-internal))
  748.  
  749. ; For each component (<name> <unspec> :type <type>) of font-info,
  750. ; there is a corresponding function:
  751.  
  752. ;(defun font-<name> (font)
  753. ;  (declare (type font font)
  754. ;       (values <type>)))
  755.  
  756. (macrolet ((make-font-info-accessors (useless-name &body fields)
  757.          `(within-definition (,useless-name make-font-info-accessors)
  758.         ,@(mapcar
  759.             #'(lambda (field)
  760.             (let* ((type (second field))
  761.                    (n (string (first field)))
  762.                    (name (xintern 'font- n))
  763.                    (accessor (xintern 'font-info- n)))
  764.               `(defun ,name (font)
  765.                  (declare (type font font))
  766.                  (declare (values ,type))
  767.                  (,accessor (font-font-info font)))))
  768.             fields))))
  769.   (make-font-info-accessors ignore
  770.     (direction draw-direction)
  771.     (min-char card16)
  772.     (max-char card16)
  773.     (min-byte1 card8)
  774.     (max-byte1 card8)
  775.     (min-byte2 card8)
  776.     (max-byte2 card8)
  777.     (all-chars-exist-p boolean)
  778.     (default-char card16)
  779.     (min-bounds vector)
  780.     (max-bounds vector)
  781.     (ascent int16)
  782.     (descent int16)
  783.     (properties font-props)))
  784.  
  785. (defun font-property (font name)
  786.   (declare (type font font)
  787.        (type keyword name))
  788.   (declare (values (or null int32)))
  789.   (getf (font-properties font) name))
  790.  
  791. (macrolet ((make-mumble-equal (type)
  792.          ;; When cached, EQ works fine, otherwise test resource id's and displays
  793.          (let ((predicate (xintern type '-equal))
  794.            (id (xintern type '-id))
  795.            (dpy (xintern type '-display)))
  796.            (if (member type *clx-cached-types*)
  797.            `(within-definition (,type make-mumble-equal)
  798.               (declaim (inline ,predicate))
  799.               (defun ,predicate (a b) (eq a b)))
  800.            `(within-definition (,type make-mumble-equal)
  801.               (defun ,predicate (a b)
  802.             (declare (type ,type a b))
  803.             (and (= (,id a) (,id b))
  804.                  (eq (,dpy a) (,dpy b)))))))))
  805.   (make-mumble-equal window)
  806.   (make-mumble-equal pixmap)
  807.   (make-mumble-equal cursor)
  808.   (make-mumble-equal font)
  809.   (make-mumble-equal gcontext)
  810.   (make-mumble-equal colormap)
  811.   (make-mumble-equal drawable))
  812.  
  813. ;;;
  814. ;;; Event-mask encode/decode functions
  815. ;;;    Converts from keyword-lists to integer and back
  816. ;;;
  817. (defun encode-mask (key-vector key-list key-type)
  818.   ;; KEY-VECTOR is a vector containg bit-position keywords.  The position of the
  819.   ;; keyword in the vector indicates its bit position in the resulting mask
  820.   ;; KEY-LIST is either a mask or a list of KEY-TYPE
  821.   ;; Returns NIL when KEY-LIST is not a list or mask.
  822.   (declare (type (simple-array keyword (*)) key-vector)
  823.        (type (or mask32 list) key-list))
  824.   (declare (values (or mask32 null)))
  825.   (typecase key-list
  826.     (mask32 key-list)
  827.     (list (let ((mask 0))
  828.         (dolist (key key-list mask)
  829.           (let ((bit (position key (the vector key-vector) :test #'eq)))
  830.         (unless bit
  831.           (x-type-error key key-type))
  832.         (setq mask (logior mask (ash 1 bit)))))))))
  833.  
  834. (defun decode-mask (key-vector mask)
  835.   (declare (type (simple-array keyword (*)) key-vector)
  836.        (type mask32 mask))
  837.   (declare (values list))
  838.   (do ((m mask (ash m -1))
  839.        (bit 0 (1+ bit))
  840.        (len (length key-vector))
  841.        (result nil))       
  842.       ((or (zerop m) (>= bit len)) result)
  843.     (declare (type mask32 m)
  844.          (fixnum bit len)
  845.          (list result))
  846.     (when (oddp m)
  847.       (push (aref key-vector bit) result))))
  848.  
  849. (defun encode-event-mask (event-mask)
  850.   (declare (type event-mask event-mask))
  851.   (declare (values mask32))
  852.   (or (encode-mask *event-mask-vector* event-mask 'event-mask-class)
  853.       (x-type-error event-mask 'event-mask)))
  854.  
  855. (defun make-event-mask (&rest keys)
  856.   ;; This is only defined for core events.
  857.   ;; Useful for constructing event-mask, pointer-event-mask, device-event-mask.
  858.   (declare (type list keys)) ;; (list event-mask-class)
  859.   (declare (values mask32))
  860.   (encode-mask *event-mask-vector* keys 'event-mask-class))
  861.  
  862. (defun make-event-keys (event-mask)
  863.   ;; This is only defined for core events.
  864.   (declare (type mask32 event-mask))
  865.   (declare (values (list event-mask-class)))
  866.   (decode-mask *event-mask-vector* event-mask))
  867.  
  868. (defun encode-device-event-mask (device-event-mask)
  869.   (declare (type device-event-mask device-event-mask))
  870.   (declare (values mask32))
  871.   (or (encode-mask *device-event-mask-vector* device-event-mask
  872.            'device-event-mask-class)
  873.       (x-type-error device-event-mask 'device-event-mask)))
  874.  
  875. (defun encode-modifier-mask (modifier-mask)
  876.   (declare (type modifier-mask modifier-mask)) ;; (list state-mask-key)
  877.   (declare (values mask16))
  878.   (or (encode-mask *state-mask-vector* modifier-mask 'modifier-key)
  879.       (and (eq modifier-mask :any) #x8000)
  880.       (x-type-error modifier-mask 'modifier-mask)))
  881.  
  882. (defun encode-state-mask (state-mask)
  883.   (declare (type (or mask16 list) state-mask)) ;; (list state-mask-key)
  884.   (declare (values mask16))
  885.   (or (encode-mask *state-mask-vector* state-mask 'state-mask-key)
  886.       (x-type-error state-mask '(or mask16 (list state-mask-key)))))
  887.  
  888. (defun make-state-mask (&rest keys)
  889.   ;; Useful for constructing modifier-mask, state-mask.
  890.   (declare (type list keys)) ;; (list state-mask-key)
  891.   (declare (values mask16))
  892.   (encode-mask *state-mask-vector* keys 'state-mask-key))
  893.  
  894. (defun make-state-keys (state-mask)
  895.   (declare (type mask16 state-mask))
  896.   (declare (values (list state-mask-key)))
  897.   (decode-mask *state-mask-vector* state-mask))
  898.  
  899. (defun encode-pointer-event-mask (pointer-event-mask)
  900.   (declare (type pointer-event-mask pointer-event-mask))
  901.   (declare (values mask32))
  902.   (or (encode-mask *pointer-event-mask-vector* pointer-event-mask
  903.            'pointer-event-mask-class)
  904.       (x-type-error pointer-event-mask 'pointer-event-mask)))
  905.