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

Contents of /src/clx/clx.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Sat Nov 16 09:27:43 1991 UTC (22 years, 5 months ago) by wlott
Branch: MAIN
Changes since 1.2: +1 -1 lines
Don't deftype base-char under CMUCL.
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    
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 ram 1.2 (defparameter *version* "MIT R5.0")
87 ram 1.1 (pushnew :clx-mit-r4 *features*)
88 ram 1.2 (pushnew :clx-mit-r5 *features*)
89 ram 1.1
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 ram 1.2 #-clx-ansi-common-lisp
165 ram 1.1 (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 wlott 1.3 #-(or clx-ansi-common-lisp cmu)
175 ram 1.2 (deftype base-char ()
176     'string-char)
177    
178 ram 1.1 ; 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 ram 1.2 (write-string " " stream)
217 ram 1.1 (prin1 (color-green color) stream)
218 ram 1.2 (write-string " " stream)
219 ram 1.1 (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 ram 1.2 (atom-cache (make-hash-table :test (atom-cache-map-test) :size *atom-cache-size*)
260 ram 1.1 :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 ram 1.2 (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 ram 1.1 (defun print-display (display stream depth)
344     (declare (type display display)
345     (ignore depth))
346     (print-unreadable-object (display stream :type t)
347 ram 1.2 (print-display-name display stream)
348     (write-string " (" stream)
349     (write-string (display-vendor-name display) stream)
350     (write-string " R" stream)
351 ram 1.1 (prin1 (display-release-number display) stream)
352 ram 1.2 (write-string ")" stream)))
353 ram 1.1
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 ram 1.2 (print-display-name (drawable-display drawable) stream)
367     (write-string " " stream)
368 ram 1.1 (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 ram 1.2 (write-string "-bit " stream)
397 ram 1.1 (princ (visual-info-class visual-info) stream)
398 ram 1.2 (write-string " " stream)
399     (print-display-name (visual-info-display visual-info) stream)
400     (write-string " " stream)
401 ram 1.1 (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 ram 1.2 (write-string " " stream))
416     (print-display-name (colormap-display colormap) stream)
417     (write-string " " stream)
418 ram 1.1 (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 ram 1.2 (print-display-name (cursor-display cursor) stream)
430     (write-string " " stream)
431 ram 1.1 (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 ram 1.2 (print-display-name (gcontext-display gcontext) stream)
529     (write-string " " stream)
530 ram 1.1 (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 ram 1.2 (print-display-name display stream)
661     (write-string "." stream)
662 ram 1.1 (princ (position screen (display-roots display)) stream))
663 ram 1.2 (write-string " " stream)
664 ram 1.1 (prin1 (screen-width screen) stream)
665 ram 1.2 (write-string "x" stream)
666 ram 1.1 (prin1 (screen-height screen) stream)
667 ram 1.2 (write-string "x" stream)
668 ram 1.1 (prin1 (screen-root-depth screen) stream)
669     (when (screen-root-visual-info screen)
670 ram 1.2 (write-string " " stream)
671 ram 1.1 (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 ram 1.2 (write-string "(gcontext)" stream))
716     (write-string " " stream)
717     (print-display-name (font-display font) stream)
718 ram 1.1 (when (font-id-internal font)
719 ram 1.2 (write-string " " stream)
720 ram 1.1 (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 ram 1.2 (declare (values (or mask32 null)))
825 ram 1.1 (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