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

Contents of /src/clx/clx.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (hide annotations)
Sat Dec 19 15:21:15 1998 UTC (15 years, 4 months ago) by dtc
Branch: MAIN
Changes since 1.9: +3 -0 lines
Add CMUCL style file-comment's; from Peter Van Eynde.
1 ram 1.1 ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
2    
3     ;;;
4     ;;; TEXAS INSTRUMENTS INCORPORATED
5     ;;; P.O. BOX 2909
6     ;;; AUSTIN, TEXAS 78769
7     ;;;
8     ;;; Copyright (C) 1987 Texas Instruments Incorporated.
9     ;;;
10     ;;; Permission is granted to any individual or institution to use, copy, modify,
11     ;;; and distribute this software, provided that this complete copyright and
12     ;;; permission notice is maintained, intact, in all copies and supporting
13     ;;; documentation.
14     ;;;
15     ;;; Texas Instruments Incorporated provides this software "as is" without
16     ;;; express or implied warranty.
17     ;;;
18 dtc 1.10 #+cmu
19     (ext:file-comment
20     "$Header: /tiger/var/lib/cvsroots/cmucl/src/clx/clx.lisp,v 1.10 1998/12/19 15:21:15 dtc Exp $")
21 ram 1.1
22     ;; Primary Interface Author:
23     ;; Robert W. Scheifler
24     ;; MIT Laboratory for Computer Science
25     ;; 545 Technology Square, Room 418
26     ;; Cambridge, MA 02139
27     ;; rws@zermatt.lcs.mit.edu
28    
29     ;; Design Contributors:
30     ;; Dan Cerys, Texas Instruments
31     ;; Scott Fahlman, CMU
32     ;; Charles Hornig, Symbolics
33     ;; John Irwin, Franz
34     ;; Kerry Kimbrough, Texas Instruments
35     ;; Chris Lindblad, MIT
36     ;; Rob MacLachlan, CMU
37     ;; Mike McMahon, Symbolics
38     ;; David Moon, Symbolics
39     ;; LaMott Oren, Texas Instruments
40     ;; Daniel Weinreb, Symbolics
41     ;; John Wroclawski, MIT
42     ;; Richard Zippel, Symbolics
43    
44     ;; Primary Implementation Author:
45     ;; LaMott Oren, Texas Instruments
46    
47     ;; Implementation Contributors:
48     ;; Charles Hornig, Symbolics
49     ;; John Irwin, Franz
50     ;; Chris Lindblad, MIT
51     ;; Robert Scheifler, MIT
52    
53     ;;;
54     ;;; Change history:
55     ;;;
56     ;;; Date Author Description
57     ;;; -------------------------------------------------------------------------------------
58     ;;; 04/07/87 R.Scheifler Created code stubs
59     ;;; 04/08/87 L.Oren Started Implementation
60     ;;; 05/11/87 L.Oren Included draft 3 revisions
61     ;;; 07/07/87 L.Oren Untested alpha release to MIT
62     ;;; 07/17/87 L.Oren Alpha release
63     ;;; 08/**/87 C.Lindblad Rewrite of buffer code
64     ;;; 08/**/87 et al Various random bug fixes
65     ;;; 08/**/87 R.Scheifler General syntactic and portability cleanups
66     ;;; 08/**/87 R.Scheifler Rewrite of gcontext caching and shadowing
67     ;;; 09/02/87 L.Oren Change events from resource-ids to objects
68     ;;; 12/24/87 R.Budzianowski KCL support
69     ;;; 12/**/87 J.Irwin ExCL 2.0 support
70     ;;; 01/20/88 L.Oren Add server extension mechanisms
71     ;;; 01/20/88 L.Oren Only force output when blocking on input
72     ;;; 01/20/88 L.Oren Uniform support for :event-window on events
73     ;;; 01/28/88 L.Oren Add window manager property functions
74     ;;; 01/28/88 L.Oren Add character translation facility
75     ;;; 02/**/87 J.Irwin Allegro 2.2 support
76    
77     ;;; This is considered a somewhat changeable interface. Discussion of better
78     ;;; integration with CLOS, support for user-specified subclassess of basic
79     ;;; objects, and the additional functionality to match the C Xlib is still in
80     ;;; progress. Bug reports should be addressed to bug-clx@expo.lcs.mit.edu.
81    
82     ;; Note: all of the following is in the package XLIB.
83    
84     (in-package :xlib)
85    
86     (pushnew :clx *features*)
87     (pushnew :xlib *features*)
88    
89 ram 1.6 (defparameter *version* "MIT R5.02")
90 ram 1.1 (pushnew :clx-mit-r4 *features*)
91 ram 1.2 (pushnew :clx-mit-r5 *features*)
92 ram 1.1
93     (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 ram 1.5 #-clx-ansi-common-lisp
166 ram 1.1 (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 ram 1.5 #-clx-ansi-common-lisp
176 ram 1.2 (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     (bits-per-pixel 8 :type (member 1 4 8 16 24 32))
249     (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     )
350    
351 ram 1.2 (defun print-display-name (display stream)
352     (declare (type (or null display) display))
353     (cond (display
354     #-allegro (princ (display-host display) stream)
355     #+allegro (write-string (string (display-host display)) stream)
356     (write-string ":" stream)
357     (princ (display-display display) stream))
358     (t
359     (write-string "(no display)" stream)))
360     display)
361    
362 ram 1.1 (defun print-display (display stream depth)
363     (declare (type display display)
364     (ignore depth))
365     (print-unreadable-object (display stream :type t)
366 ram 1.2 (print-display-name display stream)
367     (write-string " (" stream)
368     (write-string (display-vendor-name display) stream)
369     (write-string " R" stream)
370 ram 1.1 (prin1 (display-release-number display) stream)
371 ram 1.2 (write-string ")" stream)))
372 ram 1.1
373     ;;(deftype drawable () '(or window pixmap))
374    
375     (def-clx-class (drawable (:copier nil) (:print-function print-drawable))
376     (id 0 :type resource-id)
377     (display nil :type (or null display))
378     (plist nil :type list) ; Extension hook
379     )
380    
381     (defun print-drawable (drawable stream depth)
382     (declare (type drawable drawable)
383     (ignore depth))
384     (print-unreadable-object (drawable stream :type t)
385 ram 1.2 (print-display-name (drawable-display drawable) stream)
386     (write-string " " stream)
387 ram 1.1 (prin1 (drawable-id drawable) stream)))
388    
389     (def-clx-class (window (:include drawable) (:copier nil)
390     (:print-function print-drawable))
391     )
392    
393     (def-clx-class (pixmap (:include drawable) (:copier nil)
394     (:print-function print-drawable))
395     )
396    
397     (def-clx-class (visual-info (:copier nil) (:print-function print-visual-info))
398     (id 0 :type resource-id)
399     (display nil :type (or null display))
400     (class :static-gray :type (member :static-gray :static-color :true-color
401     :gray-scale :pseudo-color :direct-color))
402     (red-mask 0 :type pixel)
403     (green-mask 0 :type pixel)
404     (blue-mask 0 :type pixel)
405     (bits-per-rgb 1 :type card8)
406     (colormap-entries 0 :type card16)
407     (plist nil :type list) ; Extension hook
408     )
409    
410     (defun print-visual-info (visual-info stream depth)
411     (declare (type visual-info visual-info)
412     (ignore depth))
413     (print-unreadable-object (visual-info stream :type t)
414     (prin1 (visual-info-bits-per-rgb visual-info) stream)
415 ram 1.2 (write-string "-bit " stream)
416 ram 1.1 (princ (visual-info-class visual-info) stream)
417 ram 1.2 (write-string " " stream)
418     (print-display-name (visual-info-display visual-info) stream)
419     (write-string " " stream)
420 ram 1.1 (prin1 (visual-info-id visual-info) stream)))
421    
422     (def-clx-class (colormap (:copier nil) (:print-function print-colormap))
423     (id 0 :type resource-id)
424     (display nil :type (or null display))
425     (visual-info nil :type (or null visual-info))
426     )
427    
428     (defun print-colormap (colormap stream depth)
429     (declare (type colormap colormap)
430     (ignore depth))
431     (print-unreadable-object (colormap stream :type t)
432     (when (colormap-visual-info colormap)
433     (princ (visual-info-class (colormap-visual-info colormap)) stream)
434 ram 1.2 (write-string " " stream))
435     (print-display-name (colormap-display colormap) stream)
436     (write-string " " stream)
437 ram 1.1 (prin1 (colormap-id colormap) stream)))
438    
439     (def-clx-class (cursor (:copier nil) (:print-function print-cursor))
440     (id 0 :type resource-id)
441     (display nil :type (or null display))
442     )
443    
444     (defun print-cursor (cursor stream depth)
445     (declare (type cursor cursor)
446     (ignore depth))
447     (print-unreadable-object (cursor stream :type t)
448 ram 1.2 (print-display-name (cursor-display cursor) stream)
449     (write-string " " stream)
450 ram 1.1 (prin1 (cursor-id cursor) stream)))
451    
452     ; Atoms are accepted as strings or symbols, and are always returned as keywords.
453     ; Protocol-level integer atom ids are hidden, using a cache in the display object.
454    
455     (deftype xatom () '(or string symbol))
456    
457     (defconstant *predefined-atoms*
458     '#(nil :PRIMARY :SECONDARY :ARC :ATOM :BITMAP
459     :CARDINAL :COLORMAP :CURSOR
460     :CUT_BUFFER0 :CUT_BUFFER1 :CUT_BUFFER2 :CUT_BUFFER3
461     :CUT_BUFFER4 :CUT_BUFFER5 :CUT_BUFFER6 :CUT_BUFFER7
462     :DRAWABLE :FONT :INTEGER :PIXMAP :POINT :RECTANGLE
463     :RESOURCE_MANAGER :RGB_COLOR_MAP :RGB_BEST_MAP
464     :RGB_BLUE_MAP :RGB_DEFAULT_MAP
465     :RGB_GRAY_MAP :RGB_GREEN_MAP :RGB_RED_MAP :STRING
466     :VISUALID :WINDOW :WM_COMMAND :WM_HINTS
467     :WM_CLIENT_MACHINE :WM_ICON_NAME :WM_ICON_SIZE
468     :WM_NAME :WM_NORMAL_HINTS :WM_SIZE_HINTS
469     :WM_ZOOM_HINTS :MIN_SPACE :NORM_SPACE :MAX_SPACE
470     :END_SPACE :SUPERSCRIPT_X :SUPERSCRIPT_Y
471     :SUBSCRIPT_X :SUBSCRIPT_Y
472     :UNDERLINE_POSITION :UNDERLINE_THICKNESS
473     :STRIKEOUT_ASCENT :STRIKEOUT_DESCENT
474     :ITALIC_ANGLE :X_HEIGHT :QUAD_WIDTH :WEIGHT
475     :POINT_SIZE :RESOLUTION :COPYRIGHT :NOTICE
476     :FONT_NAME :FAMILY_NAME :FULL_NAME :CAP_HEIGHT
477     :WM_CLASS :WM_TRANSIENT_FOR))
478    
479     (deftype stringable () '(or string symbol))
480    
481     (deftype fontable () '(or stringable font))
482    
483     ; Nil stands for CurrentTime.
484    
485     (deftype timestamp () '(or null card32))
486    
487     (defconstant *bit-gravity-vector*
488     '#(:forget :north-west :north :north-east :west
489     :center :east :south-west :south
490     :south-east :static))
491    
492     (deftype bit-gravity ()
493     '(member :forget :north-west :north :north-east :west
494     :center :east :south-west :south :south-east :static))
495    
496     (defconstant *win-gravity-vector*
497     '#(:unmap :north-west :north :north-east :west
498     :center :east :south-west :south :south-east
499     :static))
500    
501     (deftype win-gravity ()
502     '(member :unmap :north-west :north :north-east :west
503     :center :east :south-west :south :south-east :static))
504    
505     (deftype grab-status ()
506     '(member :success :already-grabbed :invalid-time :not-viewable))
507    
508     ; An association list.
509    
510     (deftype alist (key-type-and-name datum-type-and-name)
511     (declare (ignore key-type-and-name datum-type-and-name))
512     'list)
513    
514 ram 1.5 (deftype clx-list (&optional element-type) (declare (ignore element-type)) 'list)
515     (deftype clx-sequence (&optional element-type) (declare (ignore element-type)) 'sequence)
516    
517 ram 1.1 ; A sequence, containing zero or more repetitions of the given elements,
518     ; with the elements expressed as (type name).
519    
520     (deftype repeat-seq (&rest elts) elts 'sequence)
521    
522     (deftype point-seq () '(repeat-seq (int16 x) (int16 y)))
523    
524     (deftype seg-seq () '(repeat-seq (int16 x1) (int16 y1) (int16 x2) (int16 y2)))
525    
526     (deftype rect-seq () '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)))
527    
528     (deftype arc-seq ()
529     '(repeat-seq (int16 x) (int16 y) (card16 width) (card16 height)
530     (angle angle1) (angle angle2)))
531    
532     (deftype gcontext-state () 'simple-vector)
533    
534     (def-clx-class (gcontext (:copier nil) (:print-function print-gcontext))
535     ;; The accessors convert to CLX data types.
536     (id 0 :type resource-id)
537     (display nil :type (or null display))
538     (drawable nil :type (or null drawable))
539 dtc 1.9 (cache-p t :type generalized-boolean)
540 ram 1.1 (server-state (allocate-gcontext-state) :type gcontext-state)
541     (local-state (allocate-gcontext-state) :type gcontext-state)
542     (plist nil :type list) ; Extension hook
543     (next nil #-explorer :type #-explorer (or null gcontext))
544     )
545    
546     (defun print-gcontext (gcontext stream depth)
547     (declare (type gcontext gcontext)
548     (ignore depth))
549     (print-unreadable-object (gcontext stream :type t)
550 ram 1.2 (print-display-name (gcontext-display gcontext) stream)
551     (write-string " " stream)
552 ram 1.1 (prin1 (gcontext-id gcontext) stream)))
553    
554     (defconstant *event-mask-vector*
555     '#(:key-press :key-release :button-press :button-release
556     :enter-window :leave-window :pointer-motion :pointer-motion-hint
557     :button-1-motion :button-2-motion :button-3-motion :button-4-motion
558     :button-5-motion :button-motion :keymap-state :exposure :visibility-change
559     :structure-notify :resize-redirect :substructure-notify :substructure-redirect
560     :focus-change :property-change :colormap-change :owner-grab-button))
561    
562     (deftype event-mask-class ()
563     '(member :key-press :key-release :owner-grab-button :button-press :button-release
564     :enter-window :leave-window :pointer-motion :pointer-motion-hint
565     :button-1-motion :button-2-motion :button-3-motion :button-4-motion
566     :button-5-motion :button-motion :exposure :visibility-change
567     :structure-notify :resize-redirect :substructure-notify :substructure-redirect
568     :focus-change :property-change :colormap-change :keymap-state))
569    
570     (deftype event-mask ()
571 ram 1.5 '(or mask32 (clx-list event-mask-class)))
572 ram 1.1
573     (defconstant *pointer-event-mask-vector*
574     '#(%error %error :button-press :button-release
575     :enter-window :leave-window :pointer-motion :pointer-motion-hint
576     :button-1-motion :button-2-motion :button-3-motion :button-4-motion
577     :button-5-motion :button-motion :keymap-state))
578    
579     (deftype pointer-event-mask-class ()
580     '(member :button-press :button-release
581     :enter-window :leave-window :pointer-motion :pointer-motion-hint
582     :button-1-motion :button-2-motion :button-3-motion :button-4-motion
583     :button-5-motion :button-motion :keymap-state))
584    
585     (deftype pointer-event-mask ()
586 ram 1.5 '(or mask32 (clx-list pointer-event-mask-class)))
587 ram 1.1
588     (defconstant *device-event-mask-vector*
589     '#(:key-press :key-release :button-press :button-release :pointer-motion
590     :button-1-motion :button-2-motion :button-3-motion :button-4-motion
591     :button-5-motion :button-motion))
592    
593     (deftype device-event-mask-class ()
594     '(member :key-press :key-release :button-press :button-release :pointer-motion
595     :button-1-motion :button-2-motion :button-3-motion :button-4-motion
596     :button-5-motion :button-motion))
597    
598     (deftype device-event-mask ()
599 ram 1.5 '(or mask32 (clx-list device-event-mask-class)))
600 ram 1.1
601     (defconstant *state-mask-vector*
602     '#(:shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5
603     :button-1 :button-2 :button-3 :button-4 :button-5))
604    
605     (deftype modifier-key ()
606     '(member :shift :lock :control :mod-1 :mod-2 :mod-3 :mod-4 :mod-5))
607    
608     (deftype modifier-mask ()
609 ram 1.5 '(or (member :any) mask16 (clx-list modifier-key)))
610 ram 1.1
611     (deftype state-mask-key ()
612     '(or modifier-key (member :button-1 :button-2 :button-3 :button-4 :button-5)))
613    
614     (defconstant *gcontext-components*
615     '(:function :plane-mask :foreground :background
616     :line-width :line-style :cap-style :join-style :fill-style
617     :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode
618     :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes
619     :arc-mode))
620    
621     (deftype gcontext-key ()
622     '(member :function :plane-mask :foreground :background
623     :line-width :line-style :cap-style :join-style :fill-style
624     :fill-rule :tile :stipple :ts-x :ts-y :font :subwindow-mode
625     :exposures :clip-x :clip-y :clip-mask :dash-offset :dashes
626     :arc-mode))
627    
628     (deftype event-key ()
629     '(member :key-press :key-release :button-press :button-release :motion-notify
630     :enter-notify :leave-notify :focus-in :focus-out :keymap-notify
631     :exposure :graphics-exposure :no-exposure :visibility-notify
632     :create-notify :destroy-notify :unmap-notify :map-notify :map-request
633     :reparent-notify :configure-notify :gravity-notify :resize-request
634     :configure-request :circulate-notify :circulate-request :property-notify
635     :selection-clear :selection-request :selection-notify
636     :colormap-notify :client-message :mapping-notify))
637    
638     (deftype error-key ()
639     '(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice
640     :illegal-request :implementation :length :match :name :pixmap :value :window))
641    
642     (deftype draw-direction ()
643     '(member :left-to-right :right-to-left))
644    
645     (defconstant *boole-vector*
646     '#(#.boole-clr #.boole-and #.boole-andc2 #.boole-1
647     #.boole-andc1 #.boole-2 #.boole-xor #.boole-ior
648     #.boole-nor #.boole-eqv #.boole-c2 #.boole-orc2
649     #.boole-c1 #.boole-orc1 #.boole-nand #.boole-set))
650    
651     (deftype boole-constant ()
652     `(member ,boole-clr ,boole-and ,boole-andc2 ,boole-1
653     ,boole-andc1 ,boole-2 ,boole-xor ,boole-ior
654     ,boole-nor ,boole-eqv ,boole-c2 ,boole-orc2
655     ,boole-c1 ,boole-orc1 ,boole-nand ,boole-set))
656    
657     (def-clx-class (screen (:copier nil) (:print-function print-screen))
658     (root nil :type (or null window))
659     (width 0 :type card16)
660     (height 0 :type card16)
661     (width-in-millimeters 0 :type card16)
662     (height-in-millimeters 0 :type card16)
663 ram 1.5 (depths nil :type (alist (image-depth depth) ((clx-list visual-info) visuals)))
664 ram 1.1 (root-depth 1 :type image-depth)
665     (root-visual-info nil :type (or null visual-info))
666     (default-colormap nil :type (or null colormap))
667     (white-pixel 0 :type pixel)
668     (black-pixel 1 :type pixel)
669     (min-installed-maps 1 :type card16)
670     (max-installed-maps 1 :type card16)
671     (backing-stores :never :type (member :never :when-mapped :always))
672 dtc 1.9 (save-unders-p nil :type generalized-boolean)
673 ram 1.1 (event-mask-at-open 0 :type mask32)
674     (plist nil :type list) ; Extension hook
675     )
676    
677     (defun print-screen (screen stream depth)
678     (declare (type screen screen)
679     (ignore depth))
680     (print-unreadable-object (screen stream :type t)
681     (let ((display (drawable-display (screen-root screen))))
682 ram 1.2 (print-display-name display stream)
683     (write-string "." stream)
684 ram 1.1 (princ (position screen (display-roots display)) stream))
685 ram 1.2 (write-string " " stream)
686 ram 1.1 (prin1 (screen-width screen) stream)
687 ram 1.2 (write-string "x" stream)
688 ram 1.1 (prin1 (screen-height screen) stream)
689 ram 1.2 (write-string "x" stream)
690 ram 1.1 (prin1 (screen-root-depth screen) stream)
691     (when (screen-root-visual-info screen)
692 ram 1.2 (write-string " " stream)
693 ram 1.1 (princ (visual-info-class (screen-root-visual-info screen)) stream))))
694    
695     (defun screen-root-visual (screen)
696     (declare (type screen screen)
697 ram 1.5 (clx-values resource-id))
698 ram 1.1 (visual-info-id (screen-root-visual-info screen)))
699    
700     ;; The list contains alternating keywords and integers.
701     (deftype font-props () 'list)
702    
703     (def-clx-class (font-info (:copier nil) (:predicate nil))
704     (direction :left-to-right :type draw-direction)
705     (min-char 0 :type card16) ;; First character in font
706     (max-char 0 :type card16) ;; Last character in font
707     (min-byte1 0 :type card8) ;; The following are for 16 bit fonts
708     (max-byte1 0 :type card8) ;; and specify min&max values for
709     (min-byte2 0 :type card8) ;; the two character bytes
710     (max-byte2 0 :type card8)
711 dtc 1.9 (all-chars-exist-p nil :type generalized-boolean)
712 ram 1.1 (default-char 0 :type card16)
713     (min-bounds nil :type (or null vector))
714     (max-bounds nil :type (or null vector))
715     (ascent 0 :type int16)
716     (descent 0 :type int16)
717     (properties nil :type font-props))
718    
719     (def-clx-class (font (:constructor make-font-internal) (:copier nil)
720     (:print-function print-font))
721     (id-internal nil :type (or null resource-id)) ;; NIL when not opened
722     (display nil :type (or null display))
723     (reference-count 0 :type fixnum)
724     (name "" :type (or null string)) ;; NIL when ID is for a GContext
725     (font-info-internal nil :type (or null font-info))
726     (char-infos-internal nil :type (or null (simple-array int16 (*))))
727 dtc 1.9 (local-only-p t :type generalized-boolean) ;; When T, always calculate text extents locally
728 ram 1.1 (plist nil :type list) ; Extension hook
729     )
730    
731     (defun print-font (font stream depth)
732     (declare (type font font)
733     (ignore depth))
734     (print-unreadable-object (font stream :type t)
735     (if (font-name font)
736     (princ (font-name font) stream)
737 ram 1.2 (write-string "(gcontext)" stream))
738     (write-string " " stream)
739     (print-display-name (font-display font) stream)
740 ram 1.1 (when (font-id-internal font)
741 ram 1.2 (write-string " " stream)
742 ram 1.1 (prin1 (font-id font) stream))))
743    
744     (defun font-id (font)
745     ;; Get font-id, opening font if needed
746     (or (font-id-internal font)
747     (open-font-internal font)))
748    
749     (defun font-font-info (font)
750     (or (font-font-info-internal font)
751     (query-font font)))
752    
753     (defun font-char-infos (font)
754     (or (font-char-infos-internal font)
755     (progn (query-font font)
756     (font-char-infos-internal font))))
757    
758     (defun make-font (&key id
759     display
760     (reference-count 0)
761     (name "")
762     (local-only-p t)
763     font-info-internal)
764     (make-font-internal :id-internal id
765     :display display
766     :reference-count reference-count
767     :name name
768     :local-only-p local-only-p
769     :font-info-internal font-info-internal))
770    
771     ; For each component (<name> <unspec> :type <type>) of font-info,
772     ; there is a corresponding function:
773    
774     ;(defun font-<name> (font)
775     ; (declare (type font font)
776 ram 1.5 ; (clx-values <type>)))
777 ram 1.1
778     (macrolet ((make-font-info-accessors (useless-name &body fields)
779     `(within-definition (,useless-name make-font-info-accessors)
780     ,@(mapcar
781     #'(lambda (field)
782     (let* ((type (second field))
783     (n (string (first field)))
784     (name (xintern 'font- n))
785     (accessor (xintern 'font-info- n)))
786     `(defun ,name (font)
787     (declare (type font font))
788 ram 1.5 (declare (clx-values ,type))
789 ram 1.1 (,accessor (font-font-info font)))))
790     fields))))
791     (make-font-info-accessors ignore
792     (direction draw-direction)
793     (min-char card16)
794     (max-char card16)
795     (min-byte1 card8)
796     (max-byte1 card8)
797     (min-byte2 card8)
798     (max-byte2 card8)
799 dtc 1.9 (all-chars-exist-p generalized-boolean)
800 ram 1.1 (default-char card16)
801     (min-bounds vector)
802     (max-bounds vector)
803     (ascent int16)
804     (descent int16)
805     (properties font-props)))
806    
807     (defun font-property (font name)
808     (declare (type font font)
809     (type keyword name))
810 ram 1.5 (declare (clx-values (or null int32)))
811 ram 1.1 (getf (font-properties font) name))
812    
813     (macrolet ((make-mumble-equal (type)
814     ;; When cached, EQ works fine, otherwise test resource id's and displays
815     (let ((predicate (xintern type '-equal))
816     (id (xintern type '-id))
817     (dpy (xintern type '-display)))
818     (if (member type *clx-cached-types*)
819     `(within-definition (,type make-mumble-equal)
820     (declaim (inline ,predicate))
821     (defun ,predicate (a b) (eq a b)))
822     `(within-definition (,type make-mumble-equal)
823     (defun ,predicate (a b)
824     (declare (type ,type a b))
825     (and (= (,id a) (,id b))
826     (eq (,dpy a) (,dpy b)))))))))
827     (make-mumble-equal window)
828     (make-mumble-equal pixmap)
829     (make-mumble-equal cursor)
830     (make-mumble-equal font)
831     (make-mumble-equal gcontext)
832     (make-mumble-equal colormap)
833     (make-mumble-equal drawable))
834    
835     ;;;
836     ;;; Event-mask encode/decode functions
837     ;;; Converts from keyword-lists to integer and back
838     ;;;
839     (defun encode-mask (key-vector key-list key-type)
840     ;; KEY-VECTOR is a vector containg bit-position keywords. The position of the
841     ;; keyword in the vector indicates its bit position in the resulting mask
842     ;; KEY-LIST is either a mask or a list of KEY-TYPE
843     ;; Returns NIL when KEY-LIST is not a list or mask.
844     (declare (type (simple-array keyword (*)) key-vector)
845     (type (or mask32 list) key-list))
846 ram 1.5 (declare (clx-values (or mask32 null)))
847 ram 1.1 (typecase key-list
848     (mask32 key-list)
849     (list (let ((mask 0))
850     (dolist (key key-list mask)
851     (let ((bit (position key (the vector key-vector) :test #'eq)))
852     (unless bit
853     (x-type-error key key-type))
854     (setq mask (logior mask (ash 1 bit)))))))))
855    
856     (defun decode-mask (key-vector mask)
857     (declare (type (simple-array keyword (*)) key-vector)
858     (type mask32 mask))
859 ram 1.5 (declare (clx-values list))
860 ram 1.1 (do ((m mask (ash m -1))
861     (bit 0 (1+ bit))
862     (len (length key-vector))
863     (result nil))
864     ((or (zerop m) (>= bit len)) result)
865     (declare (type mask32 m)
866     (fixnum bit len)
867     (list result))
868     (when (oddp m)
869     (push (aref key-vector bit) result))))
870    
871     (defun encode-event-mask (event-mask)
872     (declare (type event-mask event-mask))
873 ram 1.5 (declare (clx-values mask32))
874 ram 1.1 (or (encode-mask *event-mask-vector* event-mask 'event-mask-class)
875     (x-type-error event-mask 'event-mask)))
876    
877     (defun make-event-mask (&rest keys)
878     ;; This is only defined for core events.
879     ;; Useful for constructing event-mask, pointer-event-mask, device-event-mask.
880 ram 1.5 (declare (type (clx-list event-mask-class) keys))
881     (declare (clx-values mask32))
882 ram 1.1 (encode-mask *event-mask-vector* keys 'event-mask-class))
883    
884     (defun make-event-keys (event-mask)
885     ;; This is only defined for core events.
886     (declare (type mask32 event-mask))
887 ram 1.5 (declare (clx-values (clx-list event-mask-class)))
888 ram 1.1 (decode-mask *event-mask-vector* event-mask))
889    
890     (defun encode-device-event-mask (device-event-mask)
891     (declare (type device-event-mask device-event-mask))
892 ram 1.5 (declare (clx-values mask32))
893 ram 1.1 (or (encode-mask *device-event-mask-vector* device-event-mask
894     'device-event-mask-class)
895     (x-type-error device-event-mask 'device-event-mask)))
896    
897     (defun encode-modifier-mask (modifier-mask)
898 ram 1.5 (declare (type modifier-mask modifier-mask))
899     (declare (clx-values mask16))
900 ram 1.1 (or (encode-mask *state-mask-vector* modifier-mask 'modifier-key)
901     (and (eq modifier-mask :any) #x8000)
902     (x-type-error modifier-mask 'modifier-mask)))
903    
904     (defun encode-state-mask (state-mask)
905 ram 1.5 (declare (type (or mask16 (clx-list state-mask-key)) state-mask))
906     (declare (clx-values mask16))
907 ram 1.1 (or (encode-mask *state-mask-vector* state-mask 'state-mask-key)
908 ram 1.5 (x-type-error state-mask '(or mask16 (clx-list state-mask-key)))))
909 ram 1.1
910     (defun make-state-mask (&rest keys)
911     ;; Useful for constructing modifier-mask, state-mask.
912 ram 1.5 (declare (type (clx-list state-mask-key) keys))
913     (declare (clx-values mask16))
914 ram 1.1 (encode-mask *state-mask-vector* keys 'state-mask-key))
915    
916     (defun make-state-keys (state-mask)
917     (declare (type mask16 state-mask))
918 ram 1.5 (declare (clx-values (clx-list state-mask-key)))
919 ram 1.1 (decode-mask *state-mask-vector* state-mask))
920    
921     (defun encode-pointer-event-mask (pointer-event-mask)
922     (declare (type pointer-event-mask pointer-event-mask))
923 ram 1.5 (declare (clx-values mask32))
924 ram 1.1 (or (encode-mask *pointer-event-mask-vector* pointer-event-mask
925     'pointer-event-mask-class)
926     (x-type-error pointer-event-mask 'pointer-event-mask)))

  ViewVC Help
Powered by ViewVC 1.1.5