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

Contents of /src/clx/clx.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5