;;; -*- Mode:Common-Lisp; Package:X11; Base:10; Fonts:(MEDFNB HL12B HL12BI) -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1987, Texas Instruments Incorporated. All rights reserved.

;;; Change history:
;;;
;;;  Date       Author	Description
;;; -------------------------------------------------------------------------------------
;;; 10/27/88	WJB	Re-wrote PERFORM-DUAL-GRAPHICS to perform correctly.
;;; 10/21/88    DAN     Fixed PERFORM-DUAL-GRAPHICS to not call WINDOW-LOCK on pixmaps.
;;; 10/18/88	WJB	Added cursor locking to PERFORM-GRAPHICS
;;; 10/11/88	WJB	Added cursor remove/restore to PERFORM-GRAPHICS.
;;;  2/19/88    TWE	Changed PERFORM-DUAL-GRAPHICS to call
;;;			WINDOW-LEAST-COMMON-ANCESTOR instead of WINDOW-LCA.

;;; for use inside a server, to temporarily become inactive

(defmacro without-activation ((state) &body body)
  `(progn
     (deactivate-server ,state)
     ,@body
     (activate-server ,state)))

;;; for use inside a server, to change temporarily from active to solo
;;; beware that resources can become invalid across both transitions

(defmacro with-solo-control ((state) &body body)
  `(progn
     (deactivate-server ,state)
     (activate-solo ,state)
     ,@body
     (deactivate-solo ,state)
     (activate-server ,state)))

;;; make sure process isn't aborted in the middle of the body

(defmacro indivisibly (&body body)
;;  `(sys:without-aborts ("Indivisible Operation")
  `(without-INTERRUPTS
     . ,body))

;;; on condition, execute the body and return true
;;; make sure process isn't aborted anywhere in between

(defmacro indivisibly-when (condition &body body)
  `(indivisibly
     (when ,condition
       ,@body
       t)))

;;; atomic (setf var (func var))

(defmacro atomically (func var &optional state val)
  (let ((pred `(store-conditional (locf ,var) ,var (,func ,var))))
    (when state
      (setq pred `(indivisibly-when ,pred
		    (setf ,state ,val))))
    `(loop until ,pred
	   do (process-allow-schedule))))

;;; like process-lock, but different

(defmacro atomically-lock (accessor object who-state &optional value)
  `(loop until (store-conditional (locf (,accessor ,object)) ,value sys:current-process)
	 do (process-wait ,who-state
	      #'(lambda (o) ,(if value
				 `(eql ,value (,accessor o))
				 `(null (,accessor o))))
	      ,object)))

(defmacro atomically-unlock (accessor object &optional value)
  `(store-conditional (locf (,accessor ,object)) sys:current-process ,value))

;;; lock w, and prevent tree-lock on w and all ancestors

(defmacro with-window-locked ((w) &body body)
  (let ((state (gensym))
        (not-already-decremented (gensym)))
    `(let (,state
           (,not-already-decremented t))
       (unwind-protect
	   (progn
	     (atomically 1+ (global-state.window-busies *globals*) ,state :busy)
	     (when (plusp (global-state.tree-busies *globals*))
	       (atomically 1- (global-state.window-busies *globals*) ,state)
               (setq ,not-already-decremented nil)
	       (window-make-busy ,w (locf ,state)))
	     (atomically-lock window.busy-here ,w "Busy Here")
	     . ,body)
	 (atomically-unlock window.busy-here ,w)
	 (when ,state
	   (unless (eq ,state :busy)
	     (loop do (atomically 1- (window.busy-tree ,state))
		   while (setq ,state (window.parent ,state))))
           (when ,not-already-decremented
             (atomically 1- (global-state.window-busies *globals*))))))))

;;; prevent window-lock on w and all inferiors, and prevent tree-lock on w and all ancestors
;;; note: switching from none to some tree lockers causes a global synchronization, and it
;;; seems likely that if a server needs tree locking, it will need it for several requests
;;; in a row.  Therefore, we are lazy, and defer the final backing out of tree locking
;;; until the server is about to block.

(defmacro with-tree-locked ((w) &body body)
  (let ((state (gensym)))
    `(let (,state)
       (unwind-protect
	   (progn
	     (atomically 1+ (global-state.tree-busies *globals*) ,state :busy)
	     (process-wait "Busy Bodies"
	       #'(lambda () (zerop (global-state.window-busies *globals*))))
	     (when (window.parent ,w)
	       (window-make-busy (window.parent ,w) (locf ,state)))
	     (atomically-lock window.busy-tree ,w "Busy Tree" 0)
	     . ,body)
	 (atomically-unlock window.busy-tree ,w 0)
	 (when ,state
	   (unless (eq ,state :busy)
	     (loop do (atomically 1- (window.busy-tree ,state))
		   while (setq ,state (window.parent ,state))))
	   ; this is what we would do if not delaying
	   ; (atomically 1- (global-state.tree-busies *globals*))
	   (incf *delayed-tree-busies*))))))

(defsubst finish-tree-delays ()
  (when (plusp *delayed-tree-busies*)
    (atomically (lambda (n) (- n *delayed-tree-busies*))
		(global-state.tree-busies *globals*))
    (setq *delayed-tree-busies* 0)))

;;; mark w and all ancestors as busy
;;; this must work from root down, to avoid deadlock

(defun window-make-busy (w loc)
  (when (window.parent w)
    (window-make-busy (window.parent w) loc))
  (loop for count = (window.busy-tree w)
	until (and (numberp count)
		   (indivisibly-when
		     (store-conditional (locf (window.busy-tree w)) count (1+ count))
		     (setf (cdr loc) w)))
	do (process-wait "Busy Below" #'(lambda (w) (numberp (window.busy-tree w))) w)))

(defmacro with-pixmap-locked ((pixmap) &body body)
  `(unwind-protect
       (progn
	 (atomically-lock pixmap.lock ,pixmap "Pixmap")
	 . ,body)
     (atomically-unlock pixmap.lock ,pixmap)))

(defmacro with-gcontext-locked ((gcontext) &body body)
  `(unwind-protect
       (progn
	 (atomically-lock gcontext.lock ,gcontext "GContext")
	 . ,body)
     (atomically-unlock gcontext.lock ,gcontext)))

(defmacro with-validation ((gcontext drawable) &body body)
  `(when (or (eql (drawable.clip-mask ,drawable) (gcontext.clip-mask ,gcontext))
	     (gcontext-validate ,gcontext ,drawable))
     . ,body))


(defmacro perform-graphics ((drawable &optional gcontext) &body body)
  (when gcontext
    (setq body `((with-gcontext-locked (,gcontext)
		   (with-validation (,gcontext ,drawable)
		     . ,body)))))
  `(with-cursor-locked (:server)
     (maybe-remove-cursor ,drawable)
     (cond ((is-pixmap-p ,drawable)
	    (with-pixmap-locked (,drawable) . ,body))
	   ((and ,gcontext (gcontext.clip-p ,gcontext))
	    (with-window-locked (,drawable) . ,body))
	   (t
	    (with-tree-locked (,drawable) . ,body)))
     ))


(defmacro perform-dual-graphics ((gcontext src-drawable dst-drawable) &body body)
  ;; Assumes that if drawable is not a pixmap, must be a draw window
  
  (when gcontext
    (setq body `((with-gcontext-locked (,gcontext)
		   (with-validation (,gcontext ,dst-drawable)
		     . ,body)))))
  (let ((ancestor (gensym))
	(win (gensym))
	(pix (gensym)))
    `(let (,ancestor ,win ,pix)
       (cond ((and (pixmap-p ,src-drawable) (pixmap-p ,dst-drawable))
	      (if (eq ,src-drawable ,dst-drawable)
		  (with-pixmap-locked (,src-drawable)
		    . ,body)
		(with-pixmap-locked (,dst-drawable)
		  (with-pixmap-locked (,src-drawable)
		    . ,body))))
	     ((and (window-p ,dst-drawable) (window-p ,src-drawable))
	      (setq ,ancestor (window-least-common-ancestor ,src-drawable ,dst-drawable))
	      (with-cursor-locked (:server)
		(maybe-remove-cursor ,ancestor)
		(with-tree-locked (,ancestor)
		  . ,body)))
	     (:else
	      ;; One drawable is a window and the other is a pixmap
	      (if (pixmap-p ,src-drawable)
		  (setq ,pix ,src-drawable
			,win ,dst-drawable)
		(setq ,win ,src-drawable
		      ,pix ,dst-drawable))
	      (with-cursor-locked (:server)
		(maybe-remove-cursor ,win)
		(with-window-locked (,win)
		  (with-pixmap-locked (,pix)
		    . ,body))))))))