gcontext.lisp 46.2 KB
Newer Older
ram's avatar
ram committed
1
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
ram's avatar
ram committed
2 3 4 5

;;; GContext

;;;
6 7 8
;;;                      TEXAS INSTRUMENTS INCORPORATED
;;;                               P.O. BOX 2909
;;;                            AUSTIN, TEXAS 78769
ram's avatar
ram committed
9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27
;;;
;;; 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.
28
;;;	In addition, the macro WITH-GCONTEXT may be used to provide a
ram's avatar
ram committed
29 30 31 32 33 34 35 36 37 38 39 40 41 42 43
;;;	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.
fgilham's avatar
fgilham committed
44

ram's avatar
ram committed
45 46 47 48 49
(in-package :xlib)

;; GContext state accessors
;;	The state vector contains all card32s to speed server updating

fgilham's avatar
fgilham committed
50
(eval-when (:compile-toplevel :load-toplevel :execute)
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
  (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
ram's avatar
ram committed
90

fgilham's avatar
fgilham committed
91
(deftype gcmask () '(unsigned-byte #.+gcontext-fast-change-length+))
ram's avatar
ram committed
92 93 94 95 96 97

(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)
fgilham's avatar
fgilham committed
98 99
  ;; FIXME: these used to have glorious, but wrong, type declarations.
  ;; See if we can't return them to their former glory.
ram's avatar
ram committed
100
  (set-function #'(lambda (gcontext value)
101 102 103
                    (declare (ignore gcontext))
                    value)
                :type (or function symbol) :read-only t)
ram's avatar
ram committed
104
  (copy-function #'(lambda (from-gc to-gc value)
105 106 107
                     (declare (ignore from-gc to-gc))
                     value)
                 :type (or function symbol) :read-only t))
ram's avatar
ram committed
108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123

(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
124 125 126 127 128 129
       (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))))))
ram's avatar
ram committed
130 131 132 133 134

(defun deallocate-gcontext-state (state)
  (declare (type gcontext-state state))
  (fill state nil)
  (threaded-atomic-push state *gcontext-local-state-cache*
135
                        gcontext-state-next gcontext-state))
ram's avatar
ram committed
136 137 138 139 140 141 142 143 144 145 146 147 148 149 150

;; 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:

151 152 153 154 155
                                        ;(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>)))
ram's avatar
ram committed
156 157 158 159

;; 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:

160 161
                                        ;(defsetf gcontext-<name> (gcontext) (value)
                                        ;  )
ram's avatar
ram committed
162 163 164 165

;; Generate all the accessors and defsetf's for GContext

(defmacro xgcmask->gcmask (mask)
fgilham's avatar
fgilham committed
166
  `(the gcmask (logand ,mask #.(1- (ash 1 +gcontext-fast-change-length+)))))
ram's avatar
ram committed
167 168 169 170 171 172 173 174 175 176 177

(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
178
         (progn ,@body)
ram's avatar
ram committed
179 180 181 182
       (setf (gcontext-internal-timestamp ,local-state) 0))))

(defmacro def-gc-accessor (name type)
  (let* ((gcontext-name (xintern 'gcontext- name))
183 184
         (internal-accessor (xintern 'gcontext-internal- name))
         (internal-setfer (xintern 'set- gcontext-name)))
ram's avatar
ram committed
185 186 187
    `(within-definition (,name def-gc-accessor)

       (defun ,gcontext-name (gcontext)
188 189 190 191 192 193 194 195 196 197
         (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)))))

ram's avatar
ram committed
198
       (defun ,internal-setfer (gcontext value)
199 200 201 202 203 204 205 206 207 208 209 210 211
         (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))

ram's avatar
ram committed
212 213 214 215 216 217 218 219
       (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)
220 221
                     1
                     (the fixnum (1+ ,ts))))
ram's avatar
ram committed
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
       (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))
ram's avatar
ram committed
251
  (declare (clx-values (or null (member :none) pixmap rect-seq)
252
                       (or null (member :unsorted :y-sorted :yx-sorted :yx-banded))))
ram's avatar
ram committed
253 254
  (access-gcontext (gcontext local-state)
    (multiple-value-bind (clip clip-mask)
255 256 257
        (without-interrupts
          (values (gcontext-internal-clip local-state)
                  (gcontext-internal-clip-mask local-state)))
ram's avatar
ram committed
258
      (if (null clip)
259 260 261 262 263 264 265
          (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)))))))
ram's avatar
ram committed
266 267 268 269 270 271 272 273 274

(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)
275 276
           (type (or null (member :unsorted :y-sorted :yx-sorted :yx-banded)) ordering)
           (type (or (member :none) pixmap rect-seq) clip-mask))
ram's avatar
ram committed
277 278 279
  (unless clip-mask (x-type-error clip-mask '(or (member :none) pixmap rect-seq)))
  (multiple-value-bind (clip-mask clip)
      (typecase clip-mask
280 281 282 283 284 285 286 287 288
        (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))))
ram's avatar
ram committed
289 290
    (modify-gcontext (gcontext local-state)
      (let ((server-state (gcontext-server-state gcontext)))
291 292 293 294 295 296 297 298 299 300 301 302
        (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))))))
ram's avatar
ram committed
303 304 305 306
  clip-mask)

(defun gcontext-dashes (gcontext)
  (declare (type gcontext gcontext))
ram's avatar
ram committed
307
  (declare (clx-values (or null card8 sequence)))
ram's avatar
ram committed
308 309
  (access-gcontext (gcontext local-state)
    (multiple-value-bind (dash dashes)
310 311 312
        (without-interrupts
          (values (gcontext-internal-dash local-state)
                  (gcontext-internal-dashes local-state)))
ram's avatar
ram committed
313
      (if (null dash)
314 315
          dashes
          dash))))
ram's avatar
ram committed
316 317 318 319 320

(defsetf gcontext-dashes set-gcontext-dashes)

(defun set-gcontext-dashes (gcontext dashes)
  (declare (type gcontext gcontext)
321
           (type (or card8 sequence) dashes))
ram's avatar
ram committed
322
  (multiple-value-bind (dashes dash)
fgilham's avatar
fgilham committed
323
      (if (type? dashes 'sequence)
324 325 326 327
          (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))
fgilham's avatar
fgilham committed
328
    (modify-gcontext (gcontext local-state)
ram's avatar
ram committed
329
      (let ((server-state (gcontext-server-state gcontext)))
330 331 332 333 334 335 336
        (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))))))
ram's avatar
ram committed
337 338 339 340 341 342 343 344 345 346
  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)
347
           (type generalized-boolean metrics-p))
ram's avatar
ram committed
348
  (declare (clx-values (or null font)))
ram's avatar
ram committed
349 350 351
  (access-gcontext (gcontext local-state)
    (let ((font (gcontext-internal-font-obj local-state)))
      (or font
352 353 354 355 356
          (when metrics-p
            ;; XXX this isn't correct
            (make-font :display (gcontext-display gcontext)
                       :id (gcontext-id gcontext)
                       :name nil))))))
ram's avatar
ram committed
357 358 359 360 361

(defsetf gcontext-font set-gcontext-font)

(defun set-gcontext-font (gcontext font)
  (declare (type gcontext gcontext)
362
           (type fontable font))
ram's avatar
ram committed
363
  (let* ((font-object (if (font-p font) font (open-font (gcontext-display gcontext) font)))
364
         (font (and font-object (font-id font-object))))
ram's avatar
ram committed
365 366 367
    ;; XXX need to check font has id (and name?)
    (modify-gcontext (gcontext local-state)
      (let ((server-state (gcontext-server-state gcontext)))
368 369 370 371 372 373 374 375
        (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))))))
ram's avatar
ram committed
376 377 378 379 380 381 382 383
  font)

(defun force-gcontext-changes-internal (gcontext)
  ;; Force any delayed changes.
  (declare (type gcontext gcontext))
  #.(declare-buffun)

  (let ((display (gcontext-display gcontext))
384 385
        (server-state (gcontext-server-state gcontext))
        (local-state (gcontext-local-state gcontext)))
ram's avatar
ram committed
386
    (declare (type display display)
387
             (type gcontext-state server-state local-state))
ram's avatar
ram committed
388 389 390

    ;; Update server when timestamps don't match
    (unless (= (the fixnum (gcontext-internal-timestamp local-state))
391
               (the fixnum (gcontext-internal-timestamp server-state)))
ram's avatar
ram committed
392 393 394

      ;; The display is already locked.
      (macrolet ((with-buffer ((buffer &key timeout) &body body)
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
                   `(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))))))))
ram's avatar
ram committed
481 482 483 484 485

(defun force-gcontext-changes (gcontext)
  ;; Force any delayed changes.
  (declare (type gcontext gcontext))
  (let ((display (gcontext-display gcontext))
486 487
        (server-state (gcontext-server-state gcontext))
        (local-state (gcontext-local-state gcontext)))
ram's avatar
ram committed
488
    (declare (type gcontext-state server-state local-state))
ram's avatar
ram committed
489 490
    ;; Update server when timestamps don't match
    (unless (= (the fixnum (gcontext-internal-timestamp local-state))
491
               (the fixnum (gcontext-internal-timestamp server-state)))
ram's avatar
ram committed
492
      (with-display (display)
493
        (force-gcontext-changes-internal gcontext)))))
ram's avatar
ram committed
494 495

;;; WARNING: WITH-GCONTEXT WORKS MUCH MORE EFFICIENTLY WHEN THE OPTIONS BEING "BOUND" ARE
496 497 498
;;;          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
ram's avatar
ram committed
499 500 501
;;;          BACK.

(defmacro with-gcontext ((gcontext &rest options &key clip-ordering
502 503
                                   &allow-other-keys)
                         &body body)
ram's avatar
ram committed
504 505 506 507 508 509 510 511 512
  ;; "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
513 514 515 516 517 518 519
                              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))
ram's avatar
ram committed
520 521 522
  (remf options :clip-ordering)

  (let ((gc (gensym))
523 524 525 526 527 528 529 530
        (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)))
ram's avatar
ram committed
531 532

    (do* ((option options (cddr option))
533 534 535
          (name (car option) (car option))
          (value (cadr option) (cadr option)))
         ((endp option) (setq setfs (nreverse setfs)))
ram's avatar
ram committed
536
      (let ((index (getf *gcontext-indexes* name)))
537 538 539 540 541 542 543 544 545
        (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)))))
ram's avatar
ram committed
546
      (let ((accessor `(,(xintern 'gcontext- name) ,gc
547 548 549 550 551
                         ,@(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))))
ram's avatar
ram committed
552
    (if setfs
553 554 555 556 557 558 559 560 561 562 563 564 565
        `(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))))
ram's avatar
ram committed
566 567 568 569

(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)
570 571
           (type list indexes)
           (dynamic-extent extension-indices))
ram's avatar
ram committed
572
  (let ((local-state (gcontext-local-state gcontext))
573 574
        (saved-state (allocate-gcontext-state))
        (cache-p (gcontext-cache-p gcontext)))
ram's avatar
ram committed
575 576 577
    (declare (type gcontext-state local-state saved-state))
    (setf (gcontext-internal-timestamp saved-state) 1)
    (let ((temp-gc nil)
578 579
          (temp-mask 0)
          (extension-mask 0))
ram's avatar
ram committed
580
      (declare (type xgcmask temp-mask)
581
               (type integer extension-mask))
ram's avatar
ram committed
582
      (dolist (i indexes)
583 584 585 586 587
        (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)))))))
ram's avatar
ram committed
588
      (dolist (i extension-indices)
589 590 591 592
        (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))))))
ram's avatar
ram committed
593
      (when (or (plusp temp-mask)
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
                (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))))
ram's avatar
ram committed
628 629 630

(defun restore-gcontext-temp-state (gcontext temp-mask temp-gc)
  (declare (type gcontext gcontext temp-gc)
631
           (type xgcmask temp-mask))
ram's avatar
ram committed
632 633 634
  (let ((display (gcontext-display gcontext)))
    (declare (type display display))
    (with-display (display)
fgilham's avatar
fgilham committed
635
      (with-buffer-request (display +x-copygc+)
636 637 638
        (gcontext temp-gc)
        (gcontext gcontext)
        (card29 (xgcmask->gcmask temp-mask)))
ram's avatar
ram committed
639 640
      ;; Copy extension fields from temp back to gcontext
      (do ((bit (ash temp-mask (- *gcontext-data-length*)) (ash bit -1))
641 642 643 644 645 646
           (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))))
ram's avatar
ram committed
647
      ;; free gcontext
fgilham's avatar
fgilham committed
648
      (with-buffer-request (display +x-freegc+)
649
        (gcontext temp-gc))
ram's avatar
ram committed
650 651 652 653
      (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))
654 655 656 657 658 659 660 661 662
           (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))))))
ram's avatar
ram committed
663 664

(defun create-gcontext (&rest options &key (drawable (required-arg drawable))
665 666 667 668 669 670 671
                                        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)
ram's avatar
ram committed
672 673 674 675 676 677 678 679 680 681 682 683
  ;; 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
684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702
           (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))
ram's avatar
ram committed
703
  (declare (clx-values gcontext))
ram's avatar
ram committed
704
  (let* ((display (drawable-display drawable))
705 706 707 708
         (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)))
ram's avatar
ram committed
709
    (declare (type display display)
710 711 712
             (type gcontext gcontext)
             (type resource-id gcontextid)
             (type gcontext-state local-state server-state))
ram's avatar
ram committed
713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729
    (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)
730
                                 :clip-by-children))
ram's avatar
ram committed
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
    (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))
763

ram's avatar
ram committed
764
    (setf (gcontext-internal-timestamp server-state) 1)
ram's avatar
ram committed
765
    (setf (gcontext-internal-timestamp local-state)
766 767 768 769 770 771 772 773 774
          ;; 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))

fgilham's avatar
fgilham committed
775
    (with-buffer-request (display +x-creategc+)
ram's avatar
ram committed
776 777 778
      (resource-id gcontextid)
      (drawable drawable)
      (progn (do* ((i 0 (index+ i 1))
779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795
                   (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)))))
ram's avatar
ram committed
796 797 798

    ;; Initialize extensions
    (do ((extensions *gcontext-extensions* (cdr extensions))
799 800
         (i *gcontext-data-length* (index+ i 1)))
        ((endp extensions))
ram's avatar
ram committed
801
      (declare (type list extensions)
802
               (type array-index i))
ram's avatar
ram committed
803
      (setf (svref server-state i)
804 805
            (setf (svref local-state i)
                  (gcontext-extension-default (car extensions)))))
ram's avatar
ram committed
806 807 808

    ;; Set extension values
    (do* ((option-list options (cddr option-list))
809 810 811
          (option (car option-list) (car option-list))
          (extension))
         ((endp option-list))
ram's avatar
ram committed
812 813
      (declare (type list option-list))
      (cond ((getf *gcontext-indexes* option))	; Gcontext field
814 815 816 817 818 819 820
            ((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))
ram's avatar
ram committed
821 822 823

(defun copy-gcontext-components (src dst &rest keys)
  (declare (type gcontext src dst)
824
           (dynamic-extent keys))
ram's avatar
ram committed
825 826 827 828 829 830 831
  ;; 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))
832
          (mask 0))
ram's avatar
ram committed
833 834
      (declare (type xgcmask mask))
      (with-display (display)
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
        (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))))))))
ram's avatar
ram committed
870 871 872 873

(defun copy-gcontext (src dst)
  (declare (type gcontext src dst))
  ;; Copies all components.
fgilham's avatar
fgilham committed
874
  (apply #'copy-gcontext-components src dst +gcontext-components+)
ram's avatar
ram committed
875 876 877 878
  (do ((extensions *gcontext-extensions* (cdr extensions))
       (i *gcontext-data-length* (index+ i 1)))
      ((endp extensions))
    (funcall (gcontext-extension-copy-function (car extensions))
879 880
             src dst (svref (gcontext-local-state src) i))))

ram's avatar
ram committed
881 882 883
(defun free-gcontext (gcontext)
  (declare (type gcontext gcontext))
  (let ((display (gcontext-display gcontext)))
fgilham's avatar
fgilham committed
884
    (with-buffer-request (display +x-freegc+)
ram's avatar
ram committed
885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903
      (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
904 905
  ;;        (,set-function dst-gc value)
  ;;      (error "Can't copy unknown GContext component ~a" ',name)))
ram's avatar
ram committed
906
  (declare (type symbol name)
907 908 909
           (type t default)
           (type symbol set-function) ;; required
           (type (or symbol list) copy-function))
ram's avatar
ram committed
910
  (let* ((gc-name (intern (concatenate 'string
911 912 913 914 915 916 917
                                       (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")))
ram's avatar
ram committed
918 919
    (unless copy-function
      (setq copy-function
920 921 922 923 924
            `(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)))))
ram's avatar
ram committed
925
    `(progn
fgilham's avatar
fgilham committed
926
       (eval-when (:compile-toplevel :load-toplevel :execute)
927 928 929 930
         (defparameter ,internal-state-index
           (add-gcontext-extension ',key-name ,default ',internal-set-function
                                   ',internal-copy-function))
         ) ;; end eval-when
ram's avatar
ram committed
931
       (defun ,gc-name (gcontext)
932
         (svref (gcontext-local-state gcontext) ,internal-state-index))
ram's avatar
ram committed
933
       (defun ,setfer (gcontext new-value)
934 935 936
         (let ((local-state (gcontext-local-state gcontext)))
           (setf (gcontext-internal-timestamp local-state) 0)
           (setf (svref local-state ,internal-state-index) new-value)))
ram's avatar
ram committed
937 938
       (defsetf ,gc-name ,setfer)
       (defun ,internal-set-function (gcontext new-value)
939 940 941 942
         (,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)))
ram's avatar
ram committed
943
       (defun ,internal-copy-function (src-gc dst-gc new-value)
944 945 946 947
         (,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)))
ram's avatar
ram committed
948 949 950 951 952 953
       ',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.
954
;; The value of the special variable |Internal-GCONTEXT-name| (where "name" is
ram's avatar
ram committed
955 956 957 958 959 960
;; 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)
961 962 963
           (type t default-value)
           (type (or function symbol) set-function)
           (type (or function symbol) copy-function))
ram's avatar
ram committed
964
  (let ((number (or (position name *gcontext-extensions* :key #'gcontext-extension-name)
965 966
                    (prog1 (length *gcontext-extensions*)
                      (push nil *gcontext-extensions*)))))
ram's avatar
ram committed
967
    (setf (nth number *gcontext-extensions*)
968 969 970 971
          (make-gcontext-extension :name name
                                   :default default-value
                                   :set-function set-function
                                   :copy-function copy-function))
ram's avatar
ram committed
972
    (+ number *gcontext-data-length*)))