Skip to content
Snippets Groups Projects
frames.lisp 61.2 KiB
Newer Older
cer's avatar
cer committed
(defun position-sheet-near-pointer (sheet &optional x y)
  (unless (and x y)
    (multiple-value-setq (x y)
cer's avatar
cer committed
      (pointer-native-position (port-pointer (port sheet)))))
cer's avatar
cer committed
  (position-sheet-carefully sheet x y))

cer's avatar
cer committed

cer's avatar
cer committed
(defun display-title (frame stream &key max-width max-height)
  (declare (ignore max-width max-height))
  (with-slots (display-string) stream
    (let ((title display-string))
      (when (and (stringp title)
		 (not (string-equal title (frame-pretty-name frame))))
	;; On some hosts this will update the title bar 
	(setf (frame-pretty-name frame) title))
      (multiple-value-bind (width height)
	  (window-inside-size stream)
	(draw-text* stream (or title (frame-pretty-name frame))
		    (/ width 2) (/ height 2)
		    :align-x :center :align-y :center)))))
cer's avatar
cer committed

cer's avatar
cer committed
(defun title-capitalize (string)
  (let ((new-string (substitute #\Space #\- string)))
    (when (eq new-string string)
      (setq new-string (copy-seq new-string)))
    (nstring-capitalize new-string)))

cer's avatar
cer committed
(defun display-command-menu (frame stream &rest keys
cer's avatar
cer committed
			     &key command-table max-width max-height &allow-other-keys)
  (declare (dynamic-extent keys)
	   (ignore max-width max-height))
cer's avatar
cer committed
  (when (or (null command-table)
	    (eq command-table t))
    (setq command-table (frame-command-table frame)))
cer's avatar
cer committed
  (setq command-table (find-command-table command-table))
cer's avatar
cer committed
  (with-keywords-removed (keys keys '(:command-table))
cer's avatar
cer committed
    (if (slot-value stream 'incremental-redisplay-p)
	(apply #'display-command-menu-1 stream command-table keys)
	(apply #'display-command-table-menu command-table stream keys))))

;; Split out to avoid consing unnecessary closure environments.
(defun display-command-menu-1 (stream command-table &rest keys)
  (declare (dynamic-extent keys))
  (updating-output (stream :unique-id stream
			   :cache-value (slot-value command-table 'menu-tick))
cer's avatar
cer committed
    (apply #'display-command-table-menu command-table stream keys)))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod find-pane-named ((frame standard-application-frame) pane-name &optional (errorp t))
  (with-slots (all-panes) frame
    (cond ((second (assoc pane-name all-panes)))
	  (errorp (error "There is no pane named ~S in frame ~S" pane-name frame)))))

cer's avatar
 
cer committed


cer's avatar
cer committed
;; The contract of GET-FRAME-PANE is to get a pane upon which we can do normal
;; I/O operations, that is, a CLIM stream pane
(defmethod get-frame-pane ((frame standard-application-frame) pane-name &key (errorp t))
  (with-slots (all-panes) frame
    (let ((pane (assoc pane-name all-panes)))
      (when pane
	(map-over-sheets #'(lambda (sheet)
			     (when (typep sheet 'clim-stream-pane)
			       (return-from get-frame-pane sheet)))
			 (second pane)))
      (when errorp
cer's avatar
cer committed
	(error "There is no CLIM stream pane named ~S in frame ~S" pane-name frame)))))
cer's avatar
cer committed

cer's avatar
 
cer committed
(defmethod frame-current-panes ((frame standard-application-frame))
  (let ((panes nil)
	(top (frame-panes frame)))
    (when top
      (map-over-sheets #'(lambda (sheet)
			   (when (panep sheet)
			     (push sheet panes)))
		       top))
    panes))

cer's avatar
cer committed
(defmethod redisplay-frame-panes ((frame standard-application-frame) &key force-p)
cer's avatar
cer committed
  ;; First display all the :accept-values panes, then display the rest.
  ;; We do this to ensure that all side-effects from :accept-values panes
  ;; have taken place.
  (map-over-sheets #'(lambda (sheet)
		       (when (typep sheet 'accept-values-pane)
			 (redisplay-frame-pane frame sheet :force-p force-p)))
		   (frame-top-level-sheet frame))
  (map-over-sheets #'(lambda (sheet)
		       (when (and (typep sheet 'clim-stream-pane)
				  (not (typep sheet 'accept-values-pane)))
			 (redisplay-frame-pane frame sheet :force-p force-p)))
cer's avatar
cer committed
		   (frame-top-level-sheet frame))
  ;; Once we've redisplayed everything, the layout is done changing
  (setq *frame-layout-changing-p* nil))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod redisplay-frame-pane ((frame standard-application-frame) pane &key force-p)
cer's avatar
cer committed
  (when (symbolp pane)
    (setq pane (get-frame-pane frame pane)))
cer's avatar
cer committed
  (let* ((display-function (pane-display-function pane))
	 (ir (slot-value pane 'incremental-redisplay-p))
	 (redisplay-p (if (listp ir) (first ir) ir))
	 (check-overlapping (or (atom ir)	;default is T
				(getf (rest ir) :check-overlapping t))))
    (with-simple-restart (nil "Skip redisplaying pane ~S" pane)
      (loop
	(with-simple-restart (nil "Retry displaying pane ~S" pane)
	  (when *frame-layout-changing-p*
	    (setq force-p t))
	  (unless *sizing-application-frame*
	    (unless (member pane (slot-value frame 'initialized-panes))
	      (setq force-p t)
	      (push pane (slot-value frame 'initialized-panes))))
	  (return
	    (cond (display-function
		   (cond (redisplay-p
			  (let ((redisplay-record
				  (let ((history (stream-output-history pane)))
				    (when history
				      #+compulsive-redisplay
				      (when (> (output-record-count history :fastp t) 1)
					(cerror "Clear the output history and proceed"
						"There is more than one element in this redisplay pane")
					(window-clear pane))
				      (unless (zerop (output-record-count history :fastp t))
					(output-record-element history 0))))))
			    (cond ((or (null redisplay-record) force-p)
				   (when force-p
				     (window-clear pane))
				   (invoke-pane-redisplay-function frame pane))
				  (t 
				   (redisplay redisplay-record pane 
					      :check-overlapping check-overlapping)))))
			 ((or force-p (pane-needs-redisplay pane))
			  (multiple-value-bind (needs-display clear)
			      (pane-needs-redisplay pane)
			    (declare (ignore needs-display))
			    (when (or force-p clear)
			      (window-clear pane)))
			  (invoke-pane-display-function frame pane)))
		   (force-output pane))
		  (force-p
		   ;; If refilling from scratch, give the application a chance
		   ;; to draw stuff
		   (frame-replay frame pane))
		  ;; Otherwise do nothing, the bits will still be on display
		  ;; and will be refreshed properly if there's a damage event.
		  )))))))

;; Factored out of the above to avoid consing closures
cer's avatar
cer committed
(defun invoke-pane-redisplay-function (frame pane &rest args)
cer's avatar
cer committed
  (declare (dynamic-extent args))
  (updating-output (pane)
    (apply #'invoke-pane-display-function frame pane args)))

(defun invoke-pane-display-function (frame pane &rest args)
cer's avatar
cer committed
  (declare (dynamic-extent args))
  (let* ((df (pane-display-function pane))
	 (display-args (if (listp df) (rest df) nil))
	 (display-function (if (listp df) (first df) df)))
    ;; Cons as little as possible...
    (cond ((and (null args) (null display-args))
	   (funcall display-function frame pane))
	  ((null display-args)
	   (apply display-function frame pane args))
	  ((null args)
	   (apply display-function frame pane display-args))
	  (t
	   (apply display-function frame pane (append args display-args))))))
cer's avatar
cer committed
			 
cer's avatar
cer committed
;;; The contract of this is to replay the contents of STREAM within the region.
(defmethod frame-replay ((frame standard-application-frame) stream &optional region)
cer's avatar
cer committed
  (when (null region)
    (setq region (or (pane-viewport-region stream) (sheet-region stream))))
cer's avatar
cer committed
  (stream-replay stream region)
  (force-output stream))


cer's avatar
cer committed
(defmethod read-frame-command ((frame standard-application-frame) 
cer's avatar
cer committed
			       &key (stream *standard-input*)	;--- FRAME-STANDARD-INPUT?
cer's avatar
cer committed
			       ;; should the rest of the *command-parser*
			       ;; etc. variables be passed as keywords or bound?
			       )
  (read-command (frame-command-table frame) :stream stream))
cer's avatar
cer committed

cer's avatar
 
cer committed

cer's avatar
cer committed
(defmethod execute-frame-command :around ((frame standard-application-frame) command)
cer's avatar
 
cer committed
  (let ((top-level-process (slot-value frame 'top-level-process))
	activity)
    (if (or (and top-level-process
		 (eq top-level-process (current-process)))
	    (and (typep frame 'activity-frame)
		 (setq activity (frame-activity frame))
		 (eq (slot-value activity 'top-level-process) (current-process))))
cer's avatar
cer committed
	;; If we're in the process for the frame, just execute the command
cer's avatar
 
cer committed
	;; Or the process for the frames activity
cer's avatar
cer committed
	(call-next-method)
	;; Otherwise arrange to run the command in the frame's process
cer's avatar
 
cer committed
	(execute-command-in-frame frame command :queuep t))))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod execute-frame-command ((frame standard-application-frame) command)
  (apply (command-name command) (command-arguments command)))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod command-enabled (command-name (frame standard-application-frame))
  (with-slots (disabled-commands) frame
    (or *assume-all-commands-enabled*
	(and (not (member command-name disabled-commands))
	     (command-accessible-in-command-table-p
	       command-name (frame-command-table frame))))))

(defmethod (setf command-enabled) (enabled command-name (frame standard-application-frame))
  (with-slots (disabled-commands) frame
    (cond (enabled
	   (setf disabled-commands (delete command-name disabled-commands))
	   (note-command-enabled (frame-manager frame) frame command-name))
	  (t
	   (push command-name disabled-commands)
cer's avatar
 
cer committed
	   (note-command-disabled (frame-manager frame) frame command-name)))))
cer's avatar
cer committed

cer's avatar
cer committed

cer's avatar
cer committed
;;--- There is the compiler bug with (eval-when (compile load eval) ...)
;;--- DEFMETHOD with a CALL-NEXT-METHOD.  See to incorporate this patch.
(eval-when (#-Allegro compile load eval)
cer's avatar
cer committed
(define-condition synchronous-command-event ()
  ((command :initarg :command :reader synchronous-command-event-command))
  (:report (lambda (condition stream)
	     (format stream "Command event condition signalled for ~S"
	       (synchronous-command-event-command condition)))))
)	;eval-when

cer's avatar
cer committed
(defvar *reading-frame-command* nil)

cer's avatar
cer committed
(defmethod read-frame-command :around ((frame standard-application-frame) &key)
  (let* ((command (queue-pop (frame-command-queue frame))))
    (or command 
	(handler-bind ((synchronous-command-event
cer's avatar
cer committed
			 #'(lambda (c)
			     (return-from read-frame-command
			       (synchronous-command-event-command c)))))
cer's avatar
cer committed
	  (let ((*reading-frame-command* t))
	    (call-next-method))))))
cer's avatar
cer committed
	
cer's avatar
cer committed
;;--- Actually this should be named COMMAND-EVENT
cer's avatar
cer committed
(defclass presentation-event (event)
cer's avatar
cer committed
    ((value :initarg :value :reader presentation-event-value)
     (sheet :initarg :sheet :reader event-sheet)
     (frame :initarg :frame :reader event-frame)
     (queuep :initarg :queuep :initform nil)
     (presentation-type :initarg :presentation-type :reader event-presentation-type))
cer's avatar
cer committed
  (:default-initargs :presentation-type 'command))
cer's avatar
cer committed

(defmethod handle-event (sheet (event presentation-event))
  (process-command-event sheet event))

(defun process-command-event (sheet event)
  ;;--- This code is as bad as I feel.
  (let ((command (presentation-event-value event)))
    (if (partial-command-p command)
	(throw-highlighted-presentation
cer's avatar
cer committed
	  (make-instance 'standard-presentation
	    :object command
	    :type (event-presentation-type event))
	  *input-context*
	  (allocate-event 'pointer-button-press-event
	    :sheet sheet
	    :x 0 :y 0
	    :modifier-state 0
	    :button +pointer-left-button+))
	(let ((frame (event-frame event))
	      (activity nil))
	  (when (and *input-buffer-empty*
		     (or (eq *application-frame* frame)
			 (and (typep frame 'activity-frame)
			      (eq (frame-activity frame) *activity*)
			      (setq activity *activity*))))
	    (signal 'synchronous-command-event
		    :command command))
	  ;; Perhaps if this results directly from a user action then either
	  ;; we should do it right away, ie. lose the input buffer or beep if
	  ;; it has to be deferred,
	  (if (slot-value event 'queuep)
	      (queue-frame-command (if activity (activity-active-frame activity) frame)
				   (presentation-event-value event))
	      (beep sheet))))))
cer's avatar
cer committed

cer's avatar
 
cer committed
(defun command-callback (function &rest arguments)
  (cons #'(lambda (widget &rest args) (apply #'command-callback-1 function widget args)) arguments))

(defun command-callback-1 (function sheet &rest arguments)
  (let ((frame (pane-frame sheet)))
    (process-command-event
     sheet
     (make-instance 'presentation-event
		    :frame frame
		    :value (list* function sheet arguments)
		    :presentation-type `(command :command-table ,(frame-command-table frame))))))
		  
cer's avatar
cer committed
(defun queue-frame-command (frame command)
  (queue-push (frame-command-queue frame) command))

cer's avatar
cer committed
(defmethod execute-command-in-frame 
	   ((frame standard-application-frame) command &rest initargs)
  (declare (dynamic-extent initargs))
cer's avatar
cer committed
  (distribute-event
    (port frame)
cer's avatar
cer committed
    (apply #'allocate-event 'presentation-event 
 	   :frame frame
 	   :sheet (frame-top-level-sheet frame) 
 	   :value command 
 	   initargs)))

(defun make-command-timer (frame command 
			   &key (delay 0) interval
cer's avatar
cer committed
				(command-table (frame-command-table frame)))
  (flet ((queue-command-event (timer)
	   (declare (ignore timer))
cer's avatar
cer committed
	   (execute-command-in-frame 
	     frame command
	     :queuep t
	     :presentation-type `(command :command-table ,command-table))))
    (let ((timer (make-timer
		   :function #'queue-command-event
		   :delay delay :interval interval)))
      (add-timer timer)
cer's avatar
cer committed
      timer)))
cer's avatar
cer committed

cer's avatar
cer committed

cer's avatar
cer committed
;;; The contract of this is to find an "appropriate" presentation; i.e., one
;;; satisfying the input context specified by TYPE.  Everything that looks for a
;;; presentation goes through this so that applications can specialize it.
(defmethod frame-find-innermost-applicable-presentation
cer's avatar
cer committed
	   ((frame standard-application-frame) input-context stream x y &key event)
  (find-innermost-applicable-presentation
    input-context stream x y
    :frame frame
    :modifier-state (window-modifier-state stream) :event event))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod frame-input-context-button-press-handler
cer's avatar
cer committed
	   ((frame standard-application-frame) stream button-press-event)
cer's avatar
cer committed
  (declare (ignore stream))
  (let* ((window (event-sheet button-press-event))
	 (x (pointer-event-x button-press-event))
	 (y (pointer-event-y button-press-event))
	 (highlighted-presentation (highlighted-presentation window nil))
	 (input-context *input-context*))
cer's avatar
cer committed
    #+Allegro
cer's avatar
cer committed
    (when (and *click-outside-menu-handler*
		(output-recording-stream-p window)
cer's avatar
cer committed
		(not (region-contains-position-p (stream-output-history window) x y)))
cer's avatar
cer committed
      (funcall *click-outside-menu-handler*))
    (when highlighted-presentation
      ;; Unhighlight on the way out.
      ;; But only unhighlight the window that the click is from. 
      (unhighlight-highlighted-presentation window nil))
    (throw-highlighted-presentation 
      (or (and (output-recording-stream-p window)
	       (frame-find-innermost-applicable-presentation
cer's avatar
cer committed
		 frame input-context window x y
		 :event button-press-event))
cer's avatar
cer committed
	  *null-presentation*)
      input-context
      button-press-event)))

(defun find-frame-pane-of-type (frame type)
cer's avatar
cer committed
  (map-over-sheets #'(lambda (sheet)
cer's avatar
cer committed
		       (when (typep sheet type)
cer's avatar
cer committed
			 (return-from find-frame-pane-of-type sheet)))
		   (frame-top-level-sheet frame)))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod frame-standard-output ((frame standard-application-frame))
  (or (find-frame-pane-of-type frame 'application-pane)
      (find-frame-pane-of-type frame 'interactor-pane)))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod frame-standard-input ((frame standard-application-frame))
  (or (find-frame-pane-of-type frame 'interactor-pane)
      (frame-standard-output frame)))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod frame-query-io ((frame standard-application-frame))
cer's avatar
cer committed
  (or (frame-standard-input frame)
      (frame-standard-output frame)))

cer's avatar
cer committed
(defmethod frame-error-output ((frame standard-application-frame))
  (frame-standard-output frame))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod frame-pointer-documentation-output ((frame standard-application-frame))
cer's avatar
cer committed
  (find-frame-pane-of-type frame 'pointer-documentation-pane))
cer's avatar
cer committed

cer's avatar
cer committed
;;--- This causes direct-manipulation and menu-driven applications not to
;;--- maintain histories.  Is there a better heuristic?
(defmethod frame-maintain-presentation-histories ((frame standard-application-frame))
  (not (null (find-frame-pane-of-type frame 'interactor-pane))))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod notify-user (frame message &rest options) 
cer's avatar
cer committed
  (declare (dynamic-extent options))
  (when frame
    (setf (getf options :frame) frame))
  (apply #'frame-manager-notify-user 
	 (if frame (frame-manager frame) (find-frame-manager)) message options))
cer's avatar
cer committed

(defmethod select-file (frame &rest options) 
cer's avatar
cer committed
  (declare (dynamic-extent options))
  (when frame
    (setf (getf options :frame) frame))
  (apply #'frame-manager-select-file
	 (if frame (frame-manager frame) (find-frame-manager)) options))
cer's avatar
cer committed

cer's avatar
cer committed

;;; Pointer documentation
cer's avatar
cer committed

cer's avatar
cer committed
(defvar *pointer-documentation-interval*
	(max (floor (* 1/10 internal-time-units-per-second)) 1))
(defvar *last-pointer-documentation-time* 0)
cer's avatar
cer committed

cer's avatar
cer committed
;;; Produce pointer documentation
(defmethod frame-document-highlighted-presentation
	   ((frame standard-application-frame) presentation input-context window x y stream)
cer's avatar
cer committed
  (frame-manager-display-pointer-documentation
    (frame-manager frame) frame presentation input-context window x y stream))

cer's avatar
cer committed
(defmethod frame-manager-pointer-documentation-stream 
	   ((framem standard-frame-manager) frame stream)
  (declare (ignore frame))
  stream)

(defmethod frame-manager-display-pointer-documentation :around
cer's avatar
cer committed
	   ((framem standard-frame-manager)
	    frame presentation input-context window x y stream)
cer's avatar
cer committed
  (declare (ignore input-context x y))
  (when (frame-manager-pointer-documentation-stream framem frame stream)
cer's avatar
cer committed
    ;; The documentation should never say anything if we're not over a presentation
    (when (null presentation) 
cer's avatar
cer committed
      (frame-manager-display-pointer-documentation-string
	framem frame stream nil))
cer's avatar
cer committed
    ;; Cheap test to not do this work too often
    (let ((old-modifier-state *last-pointer-documentation-modifier-state*)
	  (modifier-state (window-modifier-state window))
	  (last-time *last-pointer-documentation-time*)
	  (time (get-internal-real-time)))
      (setq *last-pointer-documentation-modifier-state* modifier-state)
      (when (and (< time (+ last-time *pointer-documentation-interval*))
		 (= modifier-state old-modifier-state))
cer's avatar
cer committed
	(return-from frame-manager-display-pointer-documentation nil))
cer's avatar
cer committed
      (setq *last-pointer-documentation-time* time))
cer's avatar
cer committed
    (call-next-method)))

(defmethod frame-manager-display-pointer-documentation
	   ((framem standard-frame-manager)
	    frame presentation input-context window x y stream)
  (let ((stream (frame-manager-pointer-documentation-stream framem frame stream)))
cer's avatar
cer committed
    (when presentation
      (with-output-recording-options (stream :record nil)
	(with-end-of-line-action (stream :allow)
	  (with-end-of-page-action (stream :allow)
	    (window-clear stream)
	    (when (null (frame-document-highlighted-presentation-1
			  frame presentation input-context window x y stream))
	      (setq *last-pointer-documentation-time* 0))
	    (force-output stream)))))))

cer's avatar
cer committed
(defmethod frame-manager-display-pointer-documentation-string 
cer's avatar
cer committed
	   ((framem standard-frame-manager) frame stream string)
  (let ((stream (frame-manager-pointer-documentation-stream framem frame stream)))
    (when stream
      (with-output-recording-options (stream :record nil)
	(with-end-of-line-action (stream :allow)
	  (with-end-of-page-action (stream :allow)
	    (window-clear stream)
	    (when string
	      (write-string string stream))))))))
cer's avatar
cer committed

cer's avatar
cer committed
(defun frame-document-highlighted-presentation-1
       (frame presentation input-context window x y stream)
  (let ((modifier-state (window-modifier-state window)))
cer's avatar
cer committed
    (declare (type fixnum modifier-state))
cer's avatar
cer committed
    (multiple-value-bind (left   left-presentation   left-context
			  middle middle-presentation middle-context
			  right  right-presentation  right-context)
cer's avatar
cer committed
	(find-applicable-translators-for-documentation presentation input-context
						       frame window x y modifier-state)
      (let* ((*print-length* 3)
	     (*print-level* 2)
	     (*print-circle* nil)
	     (*print-array* nil)
	     (*print-readably* nil)
	     (*print-pretty* nil))
cer's avatar
cer committed
	(flet ((document-translator (translator presentation context-type
				     button-name separator)
cer's avatar
cer committed
		 ;; Assumes 5 modifier keys and the reverse ordering of *MODIFIER-KEYS*
		 (let ((bit #o20)
		       (shift-name '("h-" "s-" "m-" "c-" "sh-")))
cer's avatar
cer committed
		   (declare (type fixnum bit))
cer's avatar
cer committed
		   (repeat 5			;length of shift-name
cer's avatar
cer committed
		     (unless (zerop (logand bit modifier-state))
		       (write-string (car shift-name) stream))
		     (pop shift-name)
		     (setq bit (the fixnum (ash bit -1)))))
		 (write-string button-name stream)
		 (document-presentation-translator translator presentation context-type
						   frame nil window x y
						   :stream stream
						   :documentation-type :pointer)
		 (write-string separator stream)))
	  (declare (dynamic-extent #'document-translator))
cer's avatar
cer committed
	  ;;--- The button names should be hard-wired in.  Consider 1-button
	  ;;--- Macs and 2-button PCs...
cer's avatar
cer committed
	  (when left
cer's avatar
cer committed
	    (let ((button-name (cond ((and (eq left middle)
					   (eq left right))
cer's avatar
cer committed
				      (setq middle nil
					    right nil)
				      "L,M,R: ")
cer's avatar
cer committed
				     ((eq left middle) 
cer's avatar
cer committed
				      (setq middle nil)
				      "L,M: ")
				     (t "L: "))))
cer's avatar
cer committed
	      (document-translator left left-presentation left-context
				   button-name (if (or middle right) "; " "."))))
cer's avatar
cer committed
	  (when middle
cer's avatar
cer committed
	    (let ((button-name (cond ((eq middle right)
cer's avatar
cer committed
				      (setq right nil)
				      "M,R: ")
				     (t "M: "))))
cer's avatar
cer committed
	      (document-translator middle middle-presentation middle-context
				   button-name (if right "; " "."))))
cer's avatar
cer committed
	  (when right
cer's avatar
cer committed
	    (document-translator right right-presentation right-context
				 "R: " "."))
cer's avatar
cer committed
	  ;; Return non-NIL if any pointer documentation was produced
	  (or left middle right))))))

;; This is derived directly from FIND-APPLICABLE-TRANSLATORS
(defun find-applicable-translators-for-documentation
       (presentation input-context frame window x y modifier-state)
  ;; Assume a maximum of three pointer buttons
cer's avatar
cer committed
  (let ((left nil)   (left-presentation nil)   (left-context nil)
	(middle nil) (middle-presentation nil) (middle-context nil)
	(right nil)  (right-presentation nil)  (right-context nil))
    (macrolet ((match (translator presentation context-type button)
		 (let* ((symbol (symbol-name button))
			(button-translator (intern symbol))
			(button-presentation (fintern "~A-~A" symbol 'presentation))
			(button-context (fintern "~A-~A" symbol 'context)))
colin's avatar
colin committed
		   `(when (and (null ,button-translator)
cer's avatar
cer committed
			       (button-and-modifier-state-matches-gesture-name-p
				 (button-index ,button) modifier-state
				 (presentation-translator-gesture-name ,translator)))
		      (setq ,button-translator ,translator
cer's avatar
cer committed
			    ,button-presentation ,presentation
cer's avatar
cer committed
			    ,button-context ,context-type)))))
      (do ((presentation presentation
			 (parent-presentation-with-shared-box presentation window)))
	  ((null presentation))
	(let ((from-type (presentation-type presentation)))
	  (dolist (context input-context)
	    (let ((context-type (pop context)))	;input-context-type = first
	      (let ((translators (find-presentation-translators 
				   from-type context-type (frame-command-table frame))))
		(when translators
		  (dolist (translator translators)
		    (when (test-presentation-translator translator
							presentation context-type
							frame window x y
							:modifier-state modifier-state)
cer's avatar
cer committed
		      (match translator presentation context-type :left)
		      (match translator presentation context-type :middle)
		      (match translator presentation context-type :right)))))
cer's avatar
cer committed
	      (when (and (or left middle right)
			 *presentation-menu-translator*
			 (test-presentation-translator *presentation-menu-translator*
						       presentation context-type
						       frame window x y
						       :modifier-state modifier-state))
cer's avatar
cer committed
		(match *presentation-menu-translator* presentation context-type :left)
		(match *presentation-menu-translator* presentation context-type :middle)
		(match *presentation-menu-translator* presentation context-type :right)))))))
    (values left   left-presentation   left-context
	    middle middle-presentation middle-context
	    right  right-presentation  right-context)))