;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T; Patch-File: T;  -*-

(in-package "XLIB")

#||   Bug Report  [Hubertus 6/16/90]

Error inside the CLUE Using-Gcontext macro, when specifying a :CLIP-MASK of 
type RECT-SEQ (list of rectangles) or :DASHES of type SEQUENCE.

||#

;;; To compile the patch, the CLX files macros and bufmac
;;; must be around.

#-lispm
(eval-when (compile)
  (load (merge-pathnames "macros" user::*clx-directory*))
  (load (merge-pathnames "bufmac" user::*clx-directory*))
  )

;;; from gc-cache.lisp
;;;
(defun create-temp-gcontext (gcontext drawable)  
  (declare (type gcontext gcontext))
  (let* ((display      (drawable-display drawable))
	 (server-state (gcontext-server-state gcontext))
	 (local-state  (gcontext-local-state gcontext))
	 (gcontextid   (allocate-resource-id display gcontext 'gcontext)))
    (declare (type gcontext-state server-state local-state))
    
    (setf (gcontext-display  gcontext) display
	  (gcontext-id       gcontext) gcontextid
	  (gcontext-drawable gcontext) drawable)
    (setf (gcontext-internal-timestamp local-state) 1)
    (replace server-state (the gcontext-state *default-gcontext-state*))
    
    ;; ***** Patched [Hubertus 6/16/90]
    ;; It's not enough to replace the gcontext's server state by the
    ;; default state. You *MUST* also set the server-state fields for
    ;; CLIP-MASK and DASHES to NIL, iff the corresponding local-state fields
    ;; are NIL.
    ;; That's because values of NIL in these fields have a special
    ;; meaning for CLX (in this case the CLIP and DASH fields
    ;; contain a list of clip-rectangles or dashes, specified by the gcontext
    ;; :clip-mask or :dashes options), i.e. they must never be send in a *x-creategc*
    ;; request. This is normally ensured by the setf functions for clip-mask and dashes
    ;; (xlib::gcontext-clip-mask, xlib::gcontext-dashes). These functions
    ;; always set the server-state fields for CLIP-MASK and DASHES to NIL,
    ;; if the local-state fields are NIL. So when sending a *x-creategc*
    ;; or *x-changegc* request, these fields are ignored (because they are EQUAL).
    ;;
    ;; However the default-gcontext-state introduced above specifies non-NIL
    ;; defaults (defined by the X protocol) for these fields, so the function
    ;; crashes while trying to send NIL (a non-number).

    (when (null (gcontext-internal-clip-mask local-state))
      (setf (gcontext-internal-clip-mask server-state) nil))
    (when (null (gcontext-internal-dashes local-state))
      (setf (gcontext-internal-dashes server-state) nil))
    
    ;; ***** End of Patch

    (with-display (display)
      (setf (gcontext-internal-timestamp local-state)
	    (incf-internal-timestamp server-state))
      
      (with-buffer-request (display *x-creategc*)
	(resource-id gcontextid)
	(drawable    drawable)
	(progn
	  (do ((i     0 (index+ i 1))
	       (bit   1 (the gcmask (ash bit 1)))
	       (nbyte 16)
	       (mask  0)
	       (local 0))
	      
	      ((index>= i *gcontext-fast-change-length*)
	       (card32-put 12 mask)
	       (card16-put 2 (index-ash nbyte -2))
	       (index-incf (buffer-boffset display) nbyte))
	    
	    (declare (type array-index      i nbyte)
		     (type gcmask bit       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))))))
  gcontext)