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

Contents of /src/clx/gcontext.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (show annotations)
Wed Jun 17 18:22:46 2009 UTC (4 years, 9 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.8: +1 -1 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 ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
2
3 ;;; GContext
4
5 ;;;
6 ;;; TEXAS INSTRUMENTS INCORPORATED
7 ;;; P.O. BOX 2909
8 ;;; AUSTIN, TEXAS 78769
9 ;;;
10 ;;; Copyright (C) 1987 Texas Instruments Incorporated.
11 ;;;
12 ;;; Permission is granted to any individual or institution to use, copy, modify,
13 ;;; and distribute this software, provided that this complete copyright and
14 ;;; permission notice is maintained, intact, in all copies and supporting
15 ;;; documentation.
16 ;;;
17 ;;; Texas Instruments Incorporated provides this software "as is" without
18 ;;; express or implied warranty.
19 ;;;
20
21 ;;; GContext values are usually cached locally in the GContext object.
22 ;;; This is required because the X.11 server doesn't have any requests
23 ;;; for getting GContext values back.
24 ;;;
25 ;;; GContext changes are cached until force-GContext-changes is called.
26 ;;; All the requests that use GContext (including the GContext accessors,
27 ;;; but not the SETF's) call force-GContext-changes.
28 ;;; In addition, the macro WITH-GCONTEXT may be used to provide a
29 ;;; local view if a GContext.
30 ;;;
31 ;;; Each GContext keeps a copy of the values the server has seen, and
32 ;;; a copy altered by SETF, called the LOCAL-STATE (bad name...).
33 ;;; The SETF accessors increment a timestamp in the GContext.
34 ;;; When the timestamp in a GContext isn't equal to the timestamp in
35 ;;; the local-state, changes have been made, and force-GContext-changes
36 ;;; loops through the GContext and local-state, sending differences to
37 ;;; the server, and updating GContext.
38 ;;;
39 ;;; WITH-GCONTEXT works by BINDING the local-state slot in a GContext to
40 ;;; a private copy. This is easy (and fast) for lisp machines, but other
41 ;;; lisps will have problems. Fortunately, most other lisps don't care,
42 ;;; because they don't run in a multi-processing shared-address space
43 ;;; environment.
44
45 #+cmu
46 (ext:file-comment "$Id: gcontext.lisp,v 1.9 2009/06/17 18:22:46 rtoy Rel $")
47
48 (in-package :xlib)
49
50 ;; GContext state accessors
51 ;; The state vector contains all card32s to speed server updating
52
53 (eval-when (:compile-toplevel :load-toplevel :execute)
54 (defconstant +gcontext-fast-change-length+ #.(length +gcontext-components+))
55
56 (macrolet ((def-gc-internals (name &rest extras)
57 (let ((macros nil)
58 (indexes nil)
59 (masks nil)
60 (index 0))
61 (dolist (name +gcontext-components+)
62 (push `(defmacro ,(xintern 'gcontext-internal- name) (state)
63 `(svref ,state ,,index))
64 macros)
65 (setf (getf indexes name) index)
66 (push (ash 1 index) masks)
67 (incf index))
68 (dolist (extra extras)
69 (push `(defmacro ,(xintern 'gcontext-internal- (first extra)) (state)
70 `(svref ,state ,,index))
71 macros)
72 ;; don't override already correct index entries
73 (unless (or (getf indexes (second extra)) (getf indexes (first extra)))
74 (setf (getf indexes (or (second extra) (first extra))) index))
75 (push (logior (ash 1 index)
76 (if (second extra)
77 (ash 1 (position (second extra) +gcontext-components+))
78 0))
79 masks)
80 (incf index))
81 `(within-definition (def-gc-internals ,name)
82 ,@(nreverse macros)
83 (eval-when (:compile-toplevel :load-toplevel :execute)
84 (defvar *gcontext-data-length* ,index)
85 (defvar *gcontext-indexes* ',indexes)
86 (defvar *gcontext-masks*
87 ',(coerce (nreverse masks) 'simple-vector)
88 ))))))
89 (def-gc-internals ignore
90 (:clip :clip-mask) (:dash :dashes) (:font-obj :font) (:timestamp)))
91
92 ) ;; end EVAL-WHEN
93
94 (deftype gcmask () '(unsigned-byte #.+gcontext-fast-change-length+))
95
96 (deftype xgcmask () '(unsigned-byte #.*gcontext-data-length*))
97
98 (defstruct (gcontext-extension (:type vector) (:copier nil)) ;; un-named
99 (name nil :type symbol :read-only t)
100 (default nil :type t :read-only t)
101 ;; FIXME: these used to have glorious, but wrong, type declarations.
102 ;; See if we can't return them to their former glory.
103 (set-function #'(lambda (gcontext value)
104 (declare (ignore gcontext))
105 value)
106 :type (or function symbol) :read-only t)
107 (copy-function #'(lambda (from-gc to-gc value)
108 (declare (ignore from-gc to-gc))
109 value)
110 :type (or function symbol) :read-only t))
111
112 (defvar *gcontext-extensions* nil) ;; list of gcontext-extension
113
114 ;; Gcontext state Resource
115 (defvar *gcontext-local-state-cache* nil) ;; List of unused gcontext local states
116
117 (defmacro gcontext-state-next (state)
118 `(svref ,state 0))
119
120 (defun allocate-gcontext-state ()
121 ;; Allocate a gcontext-state
122 ;; Loop until a local state is found that's large enough to hold
123 ;; any extensions that may exist.
124 (let ((length (index+ *gcontext-data-length* (length *gcontext-extensions*))))
125 (declare (type array-index length))
126 (loop
127 (let ((state (or (threaded-atomic-pop *gcontext-local-state-cache*
128 gcontext-state-next gcontext-state)
129 (make-array length :initial-element nil))))
130 (declare (type gcontext-state state))
131 (when (index>= (length state) length)
132 (return state))))))
133
134 (defun deallocate-gcontext-state (state)
135 (declare (type gcontext-state state))
136 (fill state nil)
137 (threaded-atomic-push state *gcontext-local-state-cache*
138 gcontext-state-next gcontext-state))
139
140 ;; Temp-Gcontext Resource
141 (defvar *temp-gcontext-cache* nil) ;; List of unused gcontexts
142
143 (defun allocate-temp-gcontext ()
144 (or (threaded-atomic-pop *temp-gcontext-cache* gcontext-next gcontext)
145 (make-gcontext :local-state '#() :server-state '#())))
146
147 (defun deallocate-temp-gcontext (gc)
148 (declare (type gcontext gc))
149 (threaded-atomic-push gc *temp-gcontext-cache* gcontext-next gcontext))
150
151 ;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared
152 ;; as (type <type> <name>), there is an accessor:
153
154 ;(defun gcontext-<name> (gcontext)
155 ; ;; The value will be nil if the last value stored is unknown (e.g., the cache was
156 ; ;; off, or the component was copied from a gcontext with unknown state).
157 ; (declare (type gcontext gcontext)
158 ; (clx-values <type>)))
159
160 ;; For each argument to create-gcontext (except clip-mask and clip-ordering) declared
161 ;; as (type (or null <type>) <name>), there is a setf for the corresponding accessor:
162
163 ;(defsetf gcontext-<name> (gcontext) (value)
164 ; )
165
166 ;; Generate all the accessors and defsetf's for GContext
167
168 (defmacro xgcmask->gcmask (mask)
169 `(the gcmask (logand ,mask #.(1- (ash 1 +gcontext-fast-change-length+)))))
170
171 (defmacro access-gcontext ((gcontext local-state) &body body)
172 `(let ((,local-state (gcontext-local-state ,gcontext)))
173 (declare (type gcontext-state ,local-state))
174 ,@body))
175
176 (defmacro modify-gcontext ((gcontext local-state) &body body)
177 ;; The timestamp must be altered after the modification
178 `(let ((,local-state (gcontext-local-state ,gcontext)))
179 (declare (type gcontext-state ,local-state))
180 (prog1
181 (progn ,@body)
182 (setf (gcontext-internal-timestamp ,local-state) 0))))
183
184 (defmacro def-gc-accessor (name type)
185 (let* ((gcontext-name (xintern 'gcontext- name))
186 (internal-accessor (xintern 'gcontext-internal- name))
187 (internal-setfer (xintern 'set- gcontext-name)))
188 `(within-definition (,name def-gc-accessor)
189
190 (defun ,gcontext-name (gcontext)
191 (declare (type gcontext gcontext))
192 (declare (clx-values (or null ,type)))
193 (let ((value (,internal-accessor (gcontext-local-state gcontext))))
194 (declare (type (or null card32) value))
195 (when value ;; Don't do anything when value isn't known
196 (let ((%buffer (gcontext-display gcontext)))
197 (declare (type display %buffer))
198 %buffer
199 (decode-type ,type value)))))
200
201 (defun ,internal-setfer (gcontext value)
202 (declare (type gcontext gcontext)
203 (type ,type value))
204 (modify-gcontext (gcontext local-state)
205 (setf (,internal-accessor local-state) (encode-type ,type value))
206 ,@(when (eq type 'pixmap)
207 ;; write-through pixmaps, because the protocol allows
208 ;; the server to copy the pixmap contents at the time
209 ;; of the store, rather than continuing to share with
210 ;; the pixmap.
211 `((let ((server-state (gcontext-server-state gcontext)))
212 (setf (,internal-accessor server-state) nil))))
213 value))
214
215 (defsetf ,gcontext-name ,internal-setfer))))
216
217 (defmacro incf-internal-timestamp (state)
218 (let ((ts (gensym)))
219 `(let ((,ts (the fixnum (gcontext-internal-timestamp ,state))))
220 (declare (type fixnum ,ts))
221 ;; the probability seems low enough
222 (setq ,ts (if (= ,ts most-positive-fixnum)
223 1
224 (the fixnum (1+ ,ts))))
225 (setf (gcontext-internal-timestamp ,state) ,ts))))
226
227 (def-gc-accessor function boole-constant)
228 (def-gc-accessor plane-mask card32)
229 (def-gc-accessor foreground card32)
230 (def-gc-accessor background card32)
231 (def-gc-accessor line-width card16)
232 (def-gc-accessor line-style (member :solid :dash :double-dash))
233 (def-gc-accessor cap-style (member :not-last :butt :round :projecting))
234 (def-gc-accessor join-style (member :miter :round :bevel))
235 (def-gc-accessor fill-style (member :solid :tiled :stippled :opaque-stippled))
236 (def-gc-accessor fill-rule (member :even-odd :winding))
237 (def-gc-accessor tile pixmap)
238 (def-gc-accessor stipple pixmap)
239 (def-gc-accessor ts-x int16) ;; Tile-Stipple-X-origin
240 (def-gc-accessor ts-y int16) ;; Tile-Stipple-Y-origin
241 ;; (def-GC-accessor font font) ;; See below
242 (def-gc-accessor subwindow-mode (member :clip-by-children :include-inferiors))
243 (def-gc-accessor exposures (member :off :on))
244 (def-gc-accessor clip-x int16)
245 (def-gc-accessor clip-y int16)
246 ;; (def-GC-accessor clip-mask) ;; see below
247 (def-gc-accessor dash-offset card16)
248 ;; (def-GC-accessor dashes) ;; see below
249 (def-gc-accessor arc-mode (member :chord :pie-slice))
250
251
252 (defun gcontext-clip-mask (gcontext)
253 (declare (type gcontext gcontext))
254 (declare (clx-values (or null (member :none) pixmap rect-seq)
255 (or null (member :unsorted :y-sorted :yx-sorted :yx-banded))))
256 (access-gcontext (gcontext local-state)
257 (multiple-value-bind (clip clip-mask)
258 (without-interrupts
259 (values (gcontext-internal-clip local-state)
260 (gcontext-internal-clip-mask local-state)))
261 (if (null clip)
262 (values (let ((%buffer (gcontext-display gcontext)))
263 (declare (type display %buffer))
264 (decode-type (or (member :none) pixmap) clip-mask))
265 nil)
266 (values (second clip)
267 (decode-type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded))
268 (first clip)))))))
269
270 (defsetf gcontext-clip-mask (gcontext &optional ordering) (clip-mask)
271 ;; A bit strange, but retains setf form.
272 ;; a nil clip-mask is transformed to an empty vector
273 `(set-gcontext-clip-mask ,gcontext ,ordering ,clip-mask))
274
275 (defun set-gcontext-clip-mask (gcontext ordering clip-mask)
276 ;; a nil clip-mask is transformed to an empty vector
277 (declare (type gcontext gcontext)
278 (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) ordering)
279 (type (or (member :none) pixmap rect-seq) clip-mask))
280 (unless clip-mask (x-type-error clip-mask '(or (member :none) pixmap rect-seq)))
281 (multiple-value-bind (clip-mask clip)
282 (typecase clip-mask
283 (pixmap (values (pixmap-id clip-mask) nil))
284 ((member :none) (values 0 nil))
285 (sequence
286 (values nil
287 (list (encode-type
288 (or null (member :unsorted :y-sorted :yx-sorted :yx-banded))
289 ordering)
290 (copy-seq clip-mask))))
291 (otherwise (x-type-error clip-mask '(or (member :none) pixmap rect-seq))))
292 (modify-gcontext (gcontext local-state)
293 (let ((server-state (gcontext-server-state gcontext)))
294 (declare (type gcontext-state server-state))
295 (without-interrupts
296 (setf (gcontext-internal-clip local-state) clip
297 (gcontext-internal-clip-mask local-state) clip-mask)
298 (if (null clip)
299 (setf (gcontext-internal-clip server-state) nil)
300 (setf (gcontext-internal-clip-mask server-state) nil))
301 (when (and clip-mask (not (zerop clip-mask)))
302 ;; write-through clip-mask pixmap, because the protocol allows the
303 ;; server to copy the pixmap contents at the time of the store,
304 ;; rather than continuing to share with the pixmap.
305 (setf (gcontext-internal-clip-mask server-state) nil))))))
306 clip-mask)
307
308 (defun gcontext-dashes (gcontext)
309 (declare (type gcontext gcontext))
310 (declare (clx-values (or null card8 sequence)))
311 (access-gcontext (gcontext local-state)
312 (multiple-value-bind (dash dashes)
313 (without-interrupts
314 (values (gcontext-internal-dash local-state)
315 (gcontext-internal-dashes local-state)))
316 (if (null dash)
317 dashes
318 dash))))
319
320 (defsetf gcontext-dashes set-gcontext-dashes)
321
322 (defun set-gcontext-dashes (gcontext dashes)
323 (declare (type gcontext gcontext)
324 (type (or card8 sequence) dashes))
325 (multiple-value-bind (dashes dash)
326 (if (type? dashes 'sequence)
327 (if (zerop (length dashes))
328 (x-type-error dashes '(or card8 sequence) "non-empty sequence")
329 (values nil (or (copy-seq dashes) (vector))))
330 (values (encode-type card8 dashes) nil))
331 (modify-gcontext (gcontext local-state)
332 (let ((server-state (gcontext-server-state gcontext)))
333 (declare (type gcontext-state server-state))
334 (without-interrupts
335 (setf (gcontext-internal-dash local-state) dash
336 (gcontext-internal-dashes local-state) dashes)
337 (if (null dash)
338 (setf (gcontext-internal-dash server-state) nil)
339 (setf (gcontext-internal-dashes server-state) nil))))))
340 dashes)
341
342 (defun gcontext-font (gcontext &optional metrics-p)
343 ;; If the stored font is known, it is returned. If it is not known and
344 ;; metrics-p is false, then nil is returned. If it is not known and
345 ;; metrics-p is true, then a pseudo font is returned. Full metric and
346 ;; property information can be obtained, but the font does not have a name or
347 ;; a resource-id, and attempts to use it where a resource-id is required will
348 ;; result in an invalid-font error.
349 (declare (type gcontext gcontext)
350 (type generalized-boolean metrics-p))
351 (declare (clx-values (or null font)))
352 (access-gcontext (gcontext local-state)
353 (let ((font (gcontext-internal-font-obj local-state)))
354 (or font
355 (when metrics-p
356 ;; XXX this isn't correct
357 (make-font :display (gcontext-display gcontext)
358 :id (gcontext-id gcontext)
359 :name nil))))))
360
361 (defsetf gcontext-font set-gcontext-font)
362
363 (defun set-gcontext-font (gcontext font)
364 (declare (type gcontext gcontext)
365 (type fontable font))
366 (let* ((font-object (if (font-p font) font (open-font (gcontext-display gcontext) font)))
367 (font (and font-object (font-id font-object))))
368 ;; XXX need to check font has id (and name?)
369 (modify-gcontext (gcontext local-state)
370 (let ((server-state (gcontext-server-state gcontext)))
371 (declare (type gcontext-state server-state))
372 (without-interrupts
373 (setf (gcontext-internal-font-obj local-state) font-object
374 (gcontext-internal-font local-state) font)
375 ;; check against font, not against font-obj
376 (if (null font)
377 (setf (gcontext-internal-font server-state) nil)
378 (setf (gcontext-internal-font-obj server-state) font-object))))))
379 font)
380
381 (defun force-gcontext-changes-internal (gcontext)
382 ;; Force any delayed changes.
383 (declare (type gcontext gcontext))
384 #.(declare-buffun)
385
386 (let ((display (gcontext-display gcontext))
387 (server-state (gcontext-server-state gcontext))
388 (local-state (gcontext-local-state gcontext)))
389 (declare (type display display)
390 (type gcontext-state server-state local-state))
391
392 ;; Update server when timestamps don't match
393 (unless (= (the fixnum (gcontext-internal-timestamp local-state))
394 (the fixnum (gcontext-internal-timestamp server-state)))
395
396 ;; The display is already locked.
397 (macrolet ((with-buffer ((buffer &key timeout) &body body)
398 `(progn (progn ,buffer ,@(and timeout `(,timeout)) nil)
399 ,@body)))
400
401 ;; Because there is no locking on the local state we have to
402 ;; assume that state will change and set timestamps up front,
403 ;; otherwise by the time we figured out there were no changes
404 ;; and tried to store the server stamp as the local stamp, the
405 ;; local stamp might have since been modified.
406 (setf (gcontext-internal-timestamp local-state)
407 (incf-internal-timestamp server-state))
408
409 (block no-changes
410 (let ((last-request (buffer-last-request display)))
411 (with-buffer-request (display +x-changegc+)
412 (gcontext gcontext)
413 (progn
414 (do ((i 0 (index+ i 1))
415 (bit 1 (the xgcmask (ash bit 1)))
416 (nbyte 12)
417 (mask 0)
418 (local 0))
419 ((index>= i +gcontext-fast-change-length+)
420 (when (zerop mask)
421 ;; If nothing changed, restore last-request and quit
422 (setf (buffer-last-request display)
423 (if (zerop (buffer-last-request display))
424 nil
425 last-request))
426 (return-from no-changes nil))
427 (card29-put 8 mask)
428 (card16-put 2 (index-ash nbyte -2))
429 (index-incf (buffer-boffset display) nbyte))
430 (declare (type array-index i nbyte)
431 (type xgcmask bit)
432 (type gcmask mask)
433 (type (or null card32) local))
434 (unless (eql (the (or null card32) (svref server-state i))
435 (setq local (the (or null card32) (svref local-state i))))
436 (setf (svref server-state i) local)
437 (card32-put nbyte local)
438 (setq mask (the gcmask (logior mask bit)))
439 (index-incf nbyte 4)))))))
440
441 ;; Update GContext extensions
442 (do ((extension *gcontext-extensions* (cdr extension))
443 (i *gcontext-data-length* (index+ i 1))
444 (local))
445 ((endp extension))
446 (unless (eql (svref server-state i)
447 (setq local (svref local-state i)))
448 (setf (svref server-state i) local)
449 (funcall (gcontext-extension-set-function (car extension)) gcontext local)))
450
451 ;; Update clipping rectangles
452 (multiple-value-bind (local-clip server-clip)
453 (without-interrupts
454 (values (gcontext-internal-clip local-state)
455 (gcontext-internal-clip server-state)))
456 (unless (equalp local-clip server-clip)
457 (setf (gcontext-internal-clip server-state) nil)
458 (unless (null local-clip)
459 (with-buffer-request (display +x-setcliprectangles+)
460 (data (first local-clip))
461 (gcontext gcontext)
462 ;; XXX treat nil correctly
463 (card16 (or (gcontext-internal-clip-x local-state) 0)
464 (or (gcontext-internal-clip-y local-state) 0))
465 ;; XXX this has both int16 and card16 values
466 ((sequence :format int16) (second local-clip)))
467 (setf (gcontext-internal-clip server-state) local-clip))))
468
469 ;; Update dashes
470 (multiple-value-bind (local-dash server-dash)
471 (without-interrupts
472 (values (gcontext-internal-dash local-state)
473 (gcontext-internal-dash server-state)))
474 (unless (equalp local-dash server-dash)
475 (setf (gcontext-internal-dash server-state) nil)
476 (unless (null local-dash)
477 (with-buffer-request (display +x-setdashes+)
478 (gcontext gcontext)
479 ;; XXX treat nil correctly
480 (card16 (or (gcontext-internal-dash-offset local-state) 0)
481 (length local-dash))
482 ((sequence :format card8) local-dash))
483 (setf (gcontext-internal-dash server-state) local-dash))))))))
484
485 (defun force-gcontext-changes (gcontext)
486 ;; Force any delayed changes.
487 (declare (type gcontext gcontext))
488 (let ((display (gcontext-display gcontext))
489 (server-state (gcontext-server-state gcontext))
490 (local-state (gcontext-local-state gcontext)))
491 (declare (type gcontext-state server-state local-state))
492 ;; Update server when timestamps don't match
493 (unless (= (the fixnum (gcontext-internal-timestamp local-state))
494 (the fixnum (gcontext-internal-timestamp server-state)))
495 (with-display (display)
496 (force-gcontext-changes-internal gcontext)))))
497
498 ;;; WARNING: WITH-GCONTEXT WORKS MUCH MORE EFFICIENTLY WHEN THE OPTIONS BEING "BOUND" ARE
499 ;;; SET IN THE GCONTEXT ON ENTRY. BECAUSE THERE'S NO WAY TO GET THE VALUE OF AN
500 ;;; UNKNOWN GC COMPONENT, WITH-GCONTEXT MUST CREATE A TEMPORARY GC, COPY THE UNKNOWN
501 ;;; COMPONENTS TO THE TEMPORARY GC, ALTER THE GC BEING USED, THEN COPY COMPOMENTS
502 ;;; BACK.
503
504 (defmacro with-gcontext ((gcontext &rest options &key clip-ordering
505 &allow-other-keys)
506 &body body)
507 ;; "Binds" the gcontext components specified by options within the
508 ;; dynamic scope of the body (i.e., indefinite scope and dynamic
509 ;; extent), on a per-process basis in a multi-process environment.
510 ;; The body is not surrounded by a with-display. If cache-p is nil or
511 ;; the some component states are unknown, this will implement
512 ;; save/restore by creating a temporary gcontext and doing
513 ;; copy-gcontext-components to and from it.
514
515 (declare (arglist (gcontext &rest options &key
516 function plane-mask foreground background
517 line-width line-style cap-style join-style
518 fill-style fill-rule arc-mode tile stipple ts-x
519 ts-y font subwindow-mode exposures clip-x clip-y
520 clip-mask clip-ordering dash-offset dashes
521 &allow-other-keys)
522 &body body))
523 (remf options :clip-ordering)
524
525 (let ((gc (gensym))
526 (saved-state (gensym))
527 (temp-gc (gensym))
528 (temp-mask (gensym))
529 (temp-vars nil)
530 (setfs nil)
531 (indexes nil) ; List of gcontext field indices
532 (extension-indexes nil) ; List of gcontext extension field indices
533 (ts-index (getf *gcontext-indexes* :timestamp)))
534
535 (do* ((option options (cddr option))
536 (name (car option) (car option))
537 (value (cadr option) (cadr option)))
538 ((endp option) (setq setfs (nreverse setfs)))
539 (let ((index (getf *gcontext-indexes* name)))
540 (if index
541 (push index indexes)
542 (let ((extension (find name *gcontext-extensions*
543 :key #'gcontext-extension-name)))
544 (if extension
545 (progn
546 (push (xintern "Internal-" 'gcontext- name "-State-Index")
547 extension-indexes))
548 (x-type-error name 'gcontext-key)))))
549 (let ((accessor `(,(xintern 'gcontext- name) ,gc
550 ,@(when (eq name :clip-mask) `(,clip-ordering))))
551 (temp-var (gensym)))
552 (when value
553 (push `(,temp-var ,value) temp-vars)
554 (push `(when ,temp-var (setf ,accessor ,temp-var)) setfs))))
555 (if setfs
556 `(multiple-value-bind (,gc ,saved-state ,temp-mask ,temp-gc)
557 (copy-gcontext-local-state ,gcontext ',indexes ,@extension-indexes)
558 (declare (type gcontext ,gc)
559 (type gcontext-state ,saved-state)
560 (type xgcmask ,temp-mask)
561 (type (or null gcontext) ,temp-gc))
562 (with-gcontext-bindings (,gc ,saved-state
563 ,(append indexes extension-indexes)
564 ,ts-index ,temp-mask ,temp-gc)
565 (let ,temp-vars
566 ,@setfs)
567 ,@body))
568 `(progn ,@body))))
569
570 (defun copy-gcontext-local-state (gcontext indexes &rest extension-indices)
571 ;; Called from WITH-GCONTEXT to save the fields in GCONTEXT indicated by MASK
572 (declare (type gcontext gcontext)
573 (type list indexes)
574 (dynamic-extent extension-indices))
575 (let ((local-state (gcontext-local-state gcontext))
576 (saved-state (allocate-gcontext-state))
577 (cache-p (gcontext-cache-p gcontext)))
578 (declare (type gcontext-state local-state saved-state))
579 (setf (gcontext-internal-timestamp saved-state) 1)
580 (let ((temp-gc nil)
581 (temp-mask 0)
582 (extension-mask 0))
583 (declare (type xgcmask temp-mask)
584 (type integer extension-mask))
585 (dolist (i indexes)
586 (when (or (not (setf (svref saved-state i) (svref local-state i)))
587 (not cache-p))
588 (setq temp-mask
589 (the xgcmask (logior temp-mask
590 (the xgcmask (svref *gcontext-masks* i)))))))
591 (dolist (i extension-indices)
592 (when (or (not (setf (svref saved-state i) (svref local-state i)))
593 (not cache-p))
594 (setq extension-mask
595 (the xgcmask (logior extension-mask (ash 1 i))))))
596 (when (or (plusp temp-mask)
597 (plusp extension-mask))
598 ;; Copy to temporary GC when field unknown or cache-p false
599 (let ((display (gcontext-display gcontext)))
600 (declare (type display display))
601 (with-display (display)
602 (setq temp-gc (allocate-temp-gcontext))
603 (setf (gcontext-id temp-gc) (allocate-resource-id display gcontext 'gcontext)
604 (gcontext-display temp-gc) display
605 (gcontext-drawable temp-gc) (gcontext-drawable gcontext)
606 (gcontext-server-state temp-gc) saved-state
607 (gcontext-local-state temp-gc) saved-state)
608 ;; Create a new (temporary) gcontext
609 (with-buffer-request (display +x-creategc+)
610 (gcontext temp-gc)
611 (drawable (gcontext-drawable gcontext))
612 (card29 0))
613 ;; Copy changed components to the temporary gcontext
614 (when (plusp temp-mask)
615 (with-buffer-request (display +x-copygc+)
616 (gcontext gcontext)
617 (gcontext temp-gc)
618 (card29 (xgcmask->gcmask temp-mask))))
619 ;; Copy extension fields to the new gcontext
620 (when (plusp extension-mask)
621 ;; Copy extension fields from temp back to gcontext
622 (do ((bit (ash extension-mask (- *gcontext-data-length*)) (ash bit -1))
623 (i 0 (index+ i 1)))
624 ((zerop bit))
625 (let ((copy-function (gcontext-extension-copy-function
626 (elt *gcontext-extensions* i))))
627 (funcall copy-function gcontext temp-gc
628 (svref local-state (index+ i *gcontext-data-length*))))))
629 )))
630 (values gcontext saved-state (logior temp-mask extension-mask) temp-gc))))
631
632 (defun restore-gcontext-temp-state (gcontext temp-mask temp-gc)
633 (declare (type gcontext gcontext temp-gc)
634 (type xgcmask temp-mask))
635 (let ((display (gcontext-display gcontext)))
636 (declare (type display display))
637 (with-display (display)
638 (with-buffer-request (display +x-copygc+)
639 (gcontext temp-gc)
640 (gcontext gcontext)
641 (card29 (xgcmask->gcmask temp-mask)))
642 ;; Copy extension fields from temp back to gcontext
643 (do ((bit (ash temp-mask (- *gcontext-data-length*)) (ash bit -1))
644 (extensions *gcontext-extensions* (cdr extensions))
645 (i *gcontext-data-length* (index+ i 1))
646 (local-state (gcontext-local-state temp-gc)))
647 ((zerop bit))
648 (let ((copy-function (gcontext-extension-copy-function (car extensions))))
649 (funcall copy-function temp-gc gcontext (svref local-state i))))
650 ;; free gcontext
651 (with-buffer-request (display +x-freegc+)
652 (gcontext temp-gc))
653 (deallocate-resource-id display (gcontext-id temp-gc) 'gcontext)
654 (deallocate-temp-gcontext temp-gc)
655 ;; Copy saved state back to server state
656 (do ((server-state (gcontext-server-state gcontext))
657 (bit (xgcmask->gcmask temp-mask) (the gcmask (ash bit -1)))
658 (i 0 (index+ i 1)))
659 ((zerop bit)
660 (incf-internal-timestamp server-state))
661 (declare (type gcontext-state server-state)
662 (type gcmask bit)
663 (type array-index i))
664 (when (oddp bit)
665 (setf (svref server-state i) nil))))))
666
667 (defun create-gcontext (&rest options &key (drawable (required-arg drawable))
668 function plane-mask foreground background
669 line-width line-style cap-style join-style fill-style fill-rule
670 arc-mode tile stipple ts-x ts-y font subwindow-mode
671 exposures clip-x clip-y clip-mask clip-ordering
672 dash-offset dashes
673 (cache-p t)
674 &allow-other-keys)
675 ;; Only non-nil components are passed on in the request, but for effective caching
676 ;; assumptions have to be made about what the actual protocol defaults are. For
677 ;; all gcontext components, a value of nil causes the default gcontext value to be
678 ;; used. For clip-mask, this implies that an empty rect-seq cannot be represented
679 ;; as a list. Note: use of stringable as font will cause an implicit open-font.
680 ;; Note: papers over protocol SetClipRectangles and SetDashes special cases. If
681 ;; cache-p is true, then gcontext state is cached locally, and changing a gcontext
682 ;; component will have no effect unless the new value differs from the cached
683 ;; value. Component changes (setfs and with-gcontext) are always deferred
684 ;; regardless of the cache mode, and sent over the protocol only when required by a
685 ;; local operation or by an explicit call to force-gcontext-changes.
686 (declare (type drawable drawable) ; Required to be non-null
687 (type (or null boole-constant) function)
688 (type (or null pixel) plane-mask foreground background)
689 (type (or null card16) line-width dash-offset)
690 (type (or null int16) ts-x ts-y clip-x clip-y)
691 (type (or null (member :solid :dash :double-dash)) line-style)
692 (type (or null (member :not-last :butt :round :projecting)) cap-style)
693 (type (or null (member :miter :round :bevel)) join-style)
694 (type (or null (member :solid :tiled :opaque-stippled :stippled)) fill-style)
695 (type (or null (member :even-odd :winding)) fill-rule)
696 (type (or null (member :chord :pie-slice)) arc-mode)
697 (type (or null pixmap) tile stipple)
698 (type (or null fontable) font)
699 (type (or null (member :clip-by-children :include-inferiors)) subwindow-mode)
700 (type (or null (member :on :off)) exposures)
701 (type (or null (member :none) pixmap rect-seq) clip-mask)
702 (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) clip-ordering)
703 (type (or null card8 sequence) dashes)
704 (dynamic-extent options)
705 (type generalized-boolean cache-p))
706 (declare (clx-values gcontext))
707 (let* ((display (drawable-display drawable))
708 (gcontext (make-gcontext :display display :drawable drawable :cache-p cache-p))
709 (local-state (gcontext-local-state gcontext))
710 (server-state (gcontext-server-state gcontext))
711 (gcontextid (allocate-resource-id display gcontext 'gcontext)))
712 (declare (type display display)
713 (type gcontext gcontext)
714 (type resource-id gcontextid)
715 (type gcontext-state local-state server-state))
716 (setf (gcontext-id gcontext) gcontextid)
717
718 (unless function (setf (gcontext-function gcontext) boole-1))
719 ;; using the depth of the drawable would be better, but ...
720 (unless plane-mask (setf (gcontext-plane-mask gcontext) #xffffffff))
721 (unless foreground (setf (gcontext-foreground gcontext) 0))
722 (unless background (setf (gcontext-background gcontext) 1))
723 (unless line-width (setf (gcontext-line-width gcontext) 0))
724 (unless line-style (setf (gcontext-line-style gcontext) :solid))
725 (unless cap-style (setf (gcontext-cap-style gcontext) :butt))
726 (unless join-style (setf (gcontext-join-style gcontext) :miter))
727 (unless fill-style (setf (gcontext-fill-style gcontext) :solid))
728 (unless fill-rule (setf (gcontext-fill-rule gcontext) :even-odd))
729 (unless arc-mode (setf (gcontext-arc-mode gcontext) :pie-slice))
730 (unless ts-x (setf (gcontext-ts-x gcontext) 0))
731 (unless ts-y (setf (gcontext-ts-y gcontext) 0))
732 (unless subwindow-mode (setf (gcontext-subwindow-mode gcontext)
733 :clip-by-children))
734 (unless exposures (setf (gcontext-exposures gcontext) :on))
735 (unless clip-mask (setf (gcontext-clip-mask gcontext) :none))
736 (unless clip-x (setf (gcontext-clip-x gcontext) 0))
737 (unless clip-y (setf (gcontext-clip-y gcontext) 0))
738 (unless dashes (setf (gcontext-dashes gcontext) 4))
739 (unless dash-offset (setf (gcontext-dash-offset gcontext) 0))
740 ;; a bit kludgy, but ...
741 (replace server-state local-state)
742
743 (when function (setf (gcontext-function gcontext) function))
744 (when plane-mask (setf (gcontext-plane-mask gcontext) plane-mask))
745 (when foreground (setf (gcontext-foreground gcontext) foreground))
746 (when background (setf (gcontext-background gcontext) background))
747 (when line-width (setf (gcontext-line-width gcontext) line-width))
748 (when line-style (setf (gcontext-line-style gcontext) line-style))
749 (when cap-style (setf (gcontext-cap-style gcontext) cap-style))
750 (when join-style (setf (gcontext-join-style gcontext) join-style))
751 (when fill-style (setf (gcontext-fill-style gcontext) fill-style))
752 (when fill-rule (setf (gcontext-fill-rule gcontext) fill-rule))
753 (when arc-mode (setf (gcontext-arc-mode gcontext) arc-mode))
754 (when tile (setf (gcontext-tile gcontext) tile))
755 (when stipple (setf (gcontext-stipple gcontext) stipple))
756 (when ts-x (setf (gcontext-ts-x gcontext) ts-x))
757 (when ts-y (setf (gcontext-ts-y gcontext) ts-y))
758 (when font (setf (gcontext-font gcontext) font))
759 (when subwindow-mode (setf (gcontext-subwindow-mode gcontext) subwindow-mode))
760 (when exposures (setf (gcontext-exposures gcontext) exposures))
761 (when clip-x (setf (gcontext-clip-x gcontext) clip-x))
762 (when clip-y (setf (gcontext-clip-y gcontext) clip-y))
763 (when clip-mask (setf (gcontext-clip-mask gcontext clip-ordering) clip-mask))
764 (when dash-offset (setf (gcontext-dash-offset gcontext) dash-offset))
765 (when dashes (setf (gcontext-dashes gcontext) dashes))
766
767 (setf (gcontext-internal-timestamp server-state) 1)
768 (setf (gcontext-internal-timestamp local-state)
769 ;; SetClipRectangles or SetDashes request need to be sent?
770 (if (or (gcontext-internal-clip local-state)
771 (gcontext-internal-dash local-state))
772 ;; Yes, mark local state "modified" to ensure
773 ;; force-gcontext-changes will occur.
774 0
775 ;; No, mark local state "unmodified"
776 1))
777
778 (with-buffer-request (display +x-creategc+)
779 (resource-id gcontextid)
780 (drawable drawable)
781 (progn (do* ((i 0 (index+ i 1))
782 (bit 1 (the xgcmask (ash bit 1)))
783 (nbyte 16)
784 (mask 0)
785 (local (svref local-state i) (svref local-state i)))
786 ((index>= i +gcontext-fast-change-length+)
787 (card29-put 12 mask)
788 (card16-put 2 (index-ash nbyte -2))
789 (index-incf (buffer-boffset display) nbyte))
790 (declare (type array-index i nbyte)
791 (type xgcmask bit)
792 (type gcmask mask)
793 (type (or null card32) local))
794 (unless (eql local (the (or null card32) (svref server-state i)))
795 (setf (svref server-state i) local)
796 (card32-put nbyte local)
797 (setq mask (the gcmask (logior mask bit)))
798 (index-incf nbyte 4)))))
799
800 ;; Initialize extensions
801 (do ((extensions *gcontext-extensions* (cdr extensions))
802 (i *gcontext-data-length* (index+ i 1)))
803 ((endp extensions))
804 (declare (type list extensions)
805 (type array-index i))
806 (setf (svref server-state i)
807 (setf (svref local-state i)
808 (gcontext-extension-default (car extensions)))))
809
810 ;; Set extension values
811 (do* ((option-list options (cddr option-list))
812 (option (car option-list) (car option-list))
813 (extension))
814 ((endp option-list))
815 (declare (type list option-list))
816 (cond ((getf *gcontext-indexes* option)) ; Gcontext field
817 ((member option '(:drawable :clip-ordering :cache-p))) ; Optional parameter
818 ((setq extension (find option *gcontext-extensions*
819 :key #'gcontext-extension-name))
820 (funcall (gcontext-extension-set-function extension)
821 gcontext (second option-list)))
822 (t (x-type-error option 'gcontext-key))))
823 gcontext))
824
825 (defun copy-gcontext-components (src dst &rest keys)
826 (declare (type gcontext src dst)
827 (dynamic-extent keys))
828 ;; you might ask why this isn't just a bunch of
829 ;; (setf (gcontext-<mumble> dst) (gcontext-<mumble> src))
830 ;; the answer is that you can do that yourself if you want, what we are
831 ;; providing here is access to the protocol request, which will generally
832 ;; be more efficient (particularly for things like clip and dash lists).
833 (when keys
834 (let ((display (gcontext-display src))
835 (mask 0))
836 (declare (type xgcmask mask))
837 (with-display (display)
838 (force-gcontext-changes-internal src)
839 (force-gcontext-changes-internal dst)
840
841 ;; collect entire mask and handle extensions
842 (dolist (key keys)
843 (let ((i (getf *gcontext-indexes* key)))
844 (declare (type (or null array-index) i))
845 (if i
846 (setq mask (the xgcmask (logior mask
847 (the xgcmask (svref *gcontext-masks* i)))))
848 (let ((extension (find key *gcontext-extensions* :key #'gcontext-extension-name)))
849 (if extension
850 (funcall (gcontext-extension-copy-function extension)
851 src dst (svref (gcontext-local-state src)
852 (index+ (position extension *gcontext-extensions*) *gcontext-data-length*)))
853 (x-type-error key 'gcontext-key))))))
854
855 (when (plusp mask)
856 (do ((src-server-state (gcontext-server-state src))
857 (dst-server-state (gcontext-server-state dst))
858 (dst-local-state (gcontext-local-state dst))
859 (bit mask (the xgcmask (ash bit -1)))
860 (i 0 (index+ i 1)))
861 ((zerop bit)
862 (incf-internal-timestamp dst-server-state)
863 (setf (gcontext-internal-timestamp dst-local-state) 0))
864 (declare (type gcontext-state src-server-state dst-server-state dst-local-state)
865 (type xgcmask bit)
866 (type array-index i))
867 (when (oddp bit)
868 (setf (svref dst-local-state i)
869 (setf (svref dst-server-state i) (svref src-server-state i)))))
870 (with-buffer-request (display +x-copygc+)
871 (gcontext src dst)
872 (card29 (xgcmask->gcmask mask))))))))
873
874 (defun copy-gcontext (src dst)
875 (declare (type gcontext src dst))
876 ;; Copies all components.
877 (apply #'copy-gcontext-components src dst +gcontext-components+)
878 (do ((extensions *gcontext-extensions* (cdr extensions))
879 (i *gcontext-data-length* (index+ i 1)))
880 ((endp extensions))
881 (funcall (gcontext-extension-copy-function (car extensions))
882 src dst (svref (gcontext-local-state src) i))))
883
884 (defun free-gcontext (gcontext)
885 (declare (type gcontext gcontext))
886 (let ((display (gcontext-display gcontext)))
887 (with-buffer-request (display +x-freegc+)
888 (gcontext gcontext))
889 (deallocate-resource-id display (gcontext-id gcontext) 'gcontext)
890 (deallocate-gcontext-state (gcontext-server-state gcontext))
891 (deallocate-gcontext-state (gcontext-local-state gcontext))
892 nil))
893
894 (defmacro define-gcontext-accessor (name &key default set-function copy-function)
895 ;; This will define a new gcontext accessor called NAME.
896 ;; Defines the gcontext-NAME accessor function and its defsetf.
897 ;; Gcontext's will cache DEFAULT-VALUE and the last value SETF'ed when
898 ;; gcontext-cache-p is true. The NAME keyword will be allowed in
899 ;; CREATE-GCONTEXT, WITH-GCONTEXT, and COPY-GCONTEXT-COMPONENTS.
900 ;; SET-FUNCTION will be called with parameters (GCONTEXT NEW-VALUE)
901 ;; from create-gcontext, and force-gcontext-changes.
902 ;; COPY-FUNCTION will be called with parameters (src-gc dst-gc src-value)
903 ;; from copy-gcontext and copy-gcontext-components.
904 ;; The copy-function defaults to:
905 ;; (lambda (ignore dst-gc value)
906 ;; (if value
907 ;; (,set-function dst-gc value)
908 ;; (error "Can't copy unknown GContext component ~a" ',name)))
909 (declare (type symbol name)
910 (type t default)
911 (type symbol set-function) ;; required
912 (type (or symbol list) copy-function))
913 (let* ((gc-name (intern (concatenate 'string
914 (string 'gcontext-)
915 (string name)))) ;; in current package
916 (key-name (kintern name))
917 (setfer (xintern "Set-" gc-name))
918 (internal-set-function (xintern "Internal-Set-" gc-name))
919 (internal-copy-function (xintern "Internal-Copy-" gc-name))
920 (internal-state-index (xintern "Internal-" gc-name "-State-Index")))
921 (unless copy-function
922 (setq copy-function
923 `(lambda (src-gc dst-gc value)
924 (declare (ignore src-gc))
925 (if value
926 (,set-function dst-gc value)
927 (error "Can't copy unknown GContext component ~a" ',name)))))
928 `(progn
929 (eval-when (:compile-toplevel :load-toplevel :execute)
930 (defparameter ,internal-state-index
931 (add-gcontext-extension ',key-name ,default ',internal-set-function
932 ',internal-copy-function))
933 ) ;; end eval-when
934 (defun ,gc-name (gcontext)
935 (svref (gcontext-local-state gcontext) ,internal-state-index))
936 (defun ,setfer (gcontext new-value)
937 (let ((local-state (gcontext-local-state gcontext)))
938 (setf (gcontext-internal-timestamp local-state) 0)
939 (setf (svref local-state ,internal-state-index) new-value)))
940 (defsetf ,gc-name ,setfer)
941 (defun ,internal-set-function (gcontext new-value)
942 (,set-function gcontext new-value)
943 (setf (svref (gcontext-server-state gcontext) ,internal-state-index)
944 (setf (svref (gcontext-local-state gcontext) ,internal-state-index)
945 new-value)))
946 (defun ,internal-copy-function (src-gc dst-gc new-value)
947 (,copy-function src-gc dst-gc new-value)
948 (setf (svref (gcontext-local-state dst-gc) ,internal-state-index)
949 (setf (svref (gcontext-server-state dst-gc) ,internal-state-index)
950 new-value)))
951 ',name)))
952
953 ;; GContext extension fields are treated in much the same way as normal GContext
954 ;; components. The current value is stored in a slot of the gcontext-local-state,
955 ;; and the value known to the server is in a slot of the gcontext-server-state.
956 ;; The slot-number is defined by its position in the *gcontext-extensions* list.
957 ;; The value of the special variable |Internal-GCONTEXT-name| (where "name" is
958 ;; the extension component name) reflects this position. The position within
959 ;; *gcontext-extensions* and the value of the special value are determined at
960 ;; LOAD time to facilitate merging of seperately compiled extension files.
961
962 (defun add-gcontext-extension (name default-value set-function copy-function)
963 (declare (type symbol name)
964 (type t default-value)
965 (type (or function symbol) set-function)
966 (type (or function symbol) copy-function))
967 (let ((number (or (position name *gcontext-extensions* :key #'gcontext-extension-name)
968 (prog1 (length *gcontext-extensions*)
969 (push nil *gcontext-extensions*)))))
970 (setf (nth number *gcontext-extensions*)
971 (make-gcontext-extension :name name
972 :default default-value
973 :set-function set-function
974 :copy-function copy-function))
975 (+ number *gcontext-data-length*)))

  ViewVC Help
Powered by ViewVC 1.1.5