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

Contents of /src/clx/clx.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Thu Nov 7 16:57:16 1991 UTC (22 years, 5 months ago) by ram
Branch: MAIN
Changes since 1.1: +50 -250 lines
CLX R5 changes.
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)))

  ViewVC Help
Powered by ViewVC 1.1.5