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

Contents of /src/clx/clx.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5