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

Contents of /src/clx/clx.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5