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

Contents of /src/clx/clx.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (hide annotations)
Mon Aug 19 16:22:20 2002 UTC (11 years, 8 months ago) by toy
Branch: MAIN
CVS Tags: release-18e-base, remove_negative_zero_not_zero, LINKAGE_TABLE, PRE_LINKAGE_TABLE, release-18e-pre2, cold-pcl-base, sparc_gencgc, UNICODE-BASE, release-18e, release-18e-pre1
Branch point for: sparc_gencgc_branch, UNICODE-BRANCH, release-18e-branch, cold-pcl
Changes since 1.12: +3 -3 lines
From Iban Hatchondo:

    Also in request.lisp, we have all the grab/ungrab key/button that
    have 0 for the default value of the modifiers keyword
    argument. But the clx manual says:

    " A zero /modifier/mask is equivalent to issuing the request for all
    possible modifier-key combinations (including the combination of no
    modifiers)."

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

  ViewVC Help
Powered by ViewVC 1.1.5