cl-clx-sbcl 0.7.4.20160323-1 / usr / share / common-lisp / source / clx / gcontext.lisp

;;; -*- 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*)))