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

Contents of /src/clx/clx.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5