[e90b2f]: src / clx / gcontext.lisp Maximize Restore History

Download this file

gcontext.lisp    973 lines (897 with data), 41.4 kB

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