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

Contents of /src/clx/clx.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5