Skip to content
Snippets Groups Projects
frames.lisp 62.9 KiB
Newer Older
cer's avatar
cer committed
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-

;; $fiHeader: frames.lisp,v 1.69 1993/06/21 20:50:04 cer Exp $
cer's avatar
cer committed

(in-package :clim-internals)

cer's avatar
cer committed
"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved.
cer's avatar
cer committed
 Portions copyright (c) 1991, 1992 Franz, Inc.  All rights reserved.
 Portions copyright (c) 1989, 1990 International Lisp Associates."
cer's avatar
cer committed

cer's avatar
cer committed
(define-protocol-class application-frame ())
cer's avatar
cer committed

cer's avatar
cer committed
(defclass standard-application-frame (application-frame)
cer's avatar
cer committed
    ((name :initarg :name :accessor frame-name)
     (pretty-name :initarg :pretty-name :accessor frame-pretty-name)
     (command-table :initarg :command-table 
		    :initform (find-command-table 'user-command-table)
		    :accessor frame-command-table)
     (disabled-commands :initarg :disabled-commands :initform nil)
     ;; One of  T, NIL, or a command-table; used by the menu-bar
     (menu-bar :initarg :menu-bar :initform nil)
     (histories :initform nil)
cer's avatar
cer committed
     (frame-manager :initform nil :accessor frame-manager)
cer's avatar
 
cer committed
     (calling-frame :initform nil :reader frame-calling-frame :initarg :calling-frame)
cer's avatar
cer committed
     ;; PANES is the description of all of the named panes,
     ;; ALL-PANES is an alist that stores all of the named panes that
     ;; have actually been realized so far
     (panes :initarg :panes :accessor frame-panes)
     (all-panes :initform nil)
     (initialized-panes :initform nil)
     (pane-constructors :initarg :pane-constructors)
cer's avatar
cer committed
     (top-level-sheet :accessor frame-top-level-sheet
		      :initarg :top-level-sheet :initform nil)
cer's avatar
cer committed
     (state :initform :disowned :accessor frame-state 
	    :type (member :disowned :disabled :enabled :shrunk))
     (top-level :initarg :top-level  :accessor frame-top-level)
     (current-layout :initarg :default-layout :initform nil
		     :reader frame-current-layout)
     (geometry :initform nil :initarg :geometry :reader frame-geometry)
cer's avatar
cer committed
     (icon :initform nil :initarg :icon :reader frame-icon)
cer's avatar
cer committed
     (user-specified-position-p :initform :unspecified
				:initarg :user-specified-position-p
				:reader frame-user-specified-position-p)
     (user-specified-size-p :initform :unspecified
			    :initarg :user-specified-size-p
			    :reader frame-user-specified-size-p)
cer's avatar
cer committed
     (shell :accessor frame-shell)
     (pointer-documentation-p :initarg :pointer-documentation
			      :reader frame-pointer-documentation-p)
     (properties :initform nil :initarg :properties
		 :accessor frame-properties)
     (resizable :initarg :resize-frame
		:reader frame-resizable)
cer's avatar
cer committed
     (layout :initarg :layouts :reader frame-layouts)
cer's avatar
 
cer committed
     (top-level-process :initform nil :reader frame-top-level-process)
cer's avatar
cer committed
     (command-queue :initform (make-locking-queue) :reader frame-command-queue)
     (input-buffer :initform nil :initarg :input-buffer :reader frame-input-buffer)
     (pane-to-avv-stream-table :initform nil :accessor frame-pane-to-avv-stream-table)
     (actual-pointer-documentation-pane :initform nil :accessor frame-actual-pointer-documentation-pane))
cer's avatar
cer committed
  (:default-initargs :pointer-documentation nil
cer's avatar
cer committed
		     :layouts nil
		     :resize-frame nil
		     :top-level 'default-frame-top-level))
cer's avatar
cer committed

cer's avatar
 
cer committed

cer's avatar
cer committed
(defmethod port ((frame standard-application-frame))
  (port (frame-manager frame)))

(defmethod graft ((frame standard-application-frame))
  (graft (frame-manager frame)))

cer's avatar
cer committed
;;--- These should really be somewhere else
(defmethod frame-manager ((stream standard-encapsulating-stream))
cer's avatar
cer committed
  (frame-manager (encapsulating-stream-stream stream)))
cer's avatar
cer committed

(defmethod frame-manager ((stream t))
cer's avatar
cer committed
  (cond (*application-frame* (or (frame-manager *application-frame*)
				 (find-frame-manager)))
cer's avatar
cer committed
	(t (find-frame-manager))))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod initialize-instance :after ((frame standard-application-frame) 
				       &key 
				       (frame-manager (find-frame-manager))
				       geometry icon)
cer's avatar
cer committed
  (destructuring-bind (&key left top width height) geometry
    (declare (ignore left top width height)))
cer's avatar
cer committed
  (destructuring-bind (&key name pixmap clipping-mask) icon
cer's avatar
cer committed
    (declare (ignore name pixmap clipping-mask)))
  (when frame-manager
    (adopt-frame frame-manager frame)))
cer's avatar
cer committed

cer's avatar
 
cer committed
(defmethod find-named-color (name (frame standard-application-frame) &key (errorp t))
  (find-named-color name (frame-palette frame) :errorp errorp))

(defmethod frame-palette ((frame standard-application-frame))
  (let ((framem (frame-manager frame)))
    (if framem
	(frame-manager-palette framem)
	(and (port frame)
	     (port-default-palette (port frame))))))

cer's avatar
cer committed
;; Default method does nothing
(defmethod generate-panes ((framem standard-frame-manager)
			   (frame standard-application-frame))
cer's avatar
cer committed
  (setf (frame-panes frame) nil))

cer's avatar
 
cer committed
(defmethod generate-panes :after ((framem standard-frame-manager)
				  (frame standard-application-frame))
  (adjust-layout-requirements frame (frame-current-layout frame)))

cer's avatar
cer committed
(eval-when (compile load eval)
cer's avatar
cer committed
(defun define-application-frame-1 (name state-variables pane-descriptions
cer's avatar
cer committed
				   &key top-level layouts
cer's avatar
cer committed
					command-table disabled-commands)
  (declare (ignore name state-variables pane-descriptions top-level
		   layouts
		   disabled-commands))
  ;; If we're going to be defining commands for this application frame,
  ;; make sure there's an command table lying around so that all other
  ;; code doesn't have to be defensive against its absence.
  (when command-table
    (apply #'define-command-table-1 command-table)))
cer's avatar
cer committed
)	;eval-when

cer's avatar
cer committed
(defmacro define-application-frame (name superclasses slots &rest options)
cer's avatar
cer committed
  #+Genera (declare (zwei:indentation 1 25 2 3 3 1))
  (with-warnings-for-definition name define-application-frame
cer's avatar
cer committed
    (let (pane panes layouts top-level menu-bar pointer-documentation
cer's avatar
cer committed
	  command-definer command-table disabled-commands
	  icon geometry default-initargs)
cer's avatar
cer committed
      (macrolet ((extract (name keyword default &optional (pair t))
		   `(let ((entry (assoc ',keyword options)))
		      (cond ((null entry)
			     (setq ,name ,default))
			    (t
			     ,@(if pair
				   `((assert (= (length entry) 2) (entry)
					     "The length of the option ~S must be 2" entry)
				     (setq ,name (second entry)
					   options (delete entry options)))
				   `((assert (listp (rest entry)) (entry)
					     "The remainder of ~S must be a list" entry)
				     (setq ,name (rest entry)
cer's avatar
cer committed
					   options (delete entry options)))))))))
cer's avatar
cer committed
	(extract pane :pane nil)
	(extract panes :panes nil nil)
cer's avatar
cer committed
	(extract layouts :layouts nil nil)
cer's avatar
cer committed
	(extract top-level :top-level '(default-frame-top-level))
	(extract menu-bar :menu-bar t)
cer's avatar
cer committed
	(extract pointer-documentation :pointer-documentation nil)
cer's avatar
cer committed
	(extract command-definer :command-definer t)
	(extract command-table :command-table t)
cer's avatar
cer committed
	(extract disabled-commands :disabled-commands nil)
	(extract default-initargs :default-initargs nil nil)
	(extract icon :icon nil nil)
	(extract geometry :geometry nil nil))
cer's avatar
cer committed
      (check-type name symbol)
      (check-type superclasses list)
      (check-type slots list)
      (check-type pane list)
      (check-type panes list)
cer's avatar
cer committed
      (check-type layouts list)
cer's avatar
cer committed
      (check-type top-level list)
      (check-type disabled-commands list)
      (when (and pane panes)
cer's avatar
 
cer committed
	(error "You must use either ~S or ~S options" :pane :panes))
      (when (and panes (null layouts))
	(error "You must use ~S and ~S together" :panes :layouts))
cer's avatar
cer committed
      (when (null superclasses)
	(setq superclasses '(standard-application-frame)))
      (when (eq command-definer 't)
	(setq command-definer (fintern "~A-~A-~A" 'define name 'command)))
      (check-type command-definer symbol)
      (cond ((null command-table))
	    ((symbolp command-table)
	     (setq command-table (list command-table)))
	    (t (warn-if-command-table-invalid name command-table)))
      (when (eq (first command-table) 't)
	(setq command-table (list* name (rest command-table))))
    #-Silica (warn-if-pane-descriptions-invalid name pane-descriptions)
cer's avatar
cer committed
    #-Silica (warn-if-layouts-invalid name layouts pane-descriptions)
cer's avatar
cer committed
    (let ((pane-constructors 
cer's avatar
cer committed
	    (cond (panes
cer's avatar
cer committed
		   (compute-pane-constructor-code panes))
		  (pane
cer's avatar
cer committed
 		   (compute-pane-constructor-code `((,name ,pane))))))
 	  (layout-value
	    `(list ,@(mapcar
		       #'(lambda (layout)
			   (destructuring-bind (name panes &rest sizes) layout
cer's avatar
 
cer committed
			     (check-type sizes list)
cer's avatar
cer committed
			     (if sizes
				 `(list ',name ',panes 
					,@(mapcar #'(lambda (pane-and-size)
cer's avatar
 
cer committed
						      (destructuring-bind (pane &rest sizes) pane-and-size
							`(list ',pane
							       ,@sizes)))
cer's avatar
cer committed
						  sizes))
				 `',layout)))
		       layouts))))
cer's avatar
cer committed
      `(progn
	 (eval-when (compile)
	   (when ',command-table
	     (setf (compile-time-property ',(first command-table) 'command-table-name) t))
	   (define-application-frame-1 ',name ',slots ,pane-constructors
cer's avatar
cer committed
				       :layouts ,layout-value
cer's avatar
cer committed
				       :top-level ',top-level
				       :command-table ',command-table))
	 (define-group ,name define-application-frame
	   (defclass ,name ,superclasses ,slots
	     ,@options
	     (:default-initargs
cer's avatar
cer committed
	       :layouts ,layout-value
cer's avatar
cer committed
	       :menu-bar ',menu-bar
	       :pointer-documentation ',pointer-documentation
cer's avatar
cer committed
	       ,@(and command-table `(:command-table ',(car command-table)))
	       ,@(and top-level `(:top-level ',top-level))
cer's avatar
cer committed
	       ,@(and panes `(:pane-constructors ,pane-constructors))
cer's avatar
cer committed
	       ,@(and layouts `(:default-layout ',(caar layouts)))
cer's avatar
cer committed
	       ,@(and icon `(:icon (list ,@icon)))
	       ,@(and geometry `(:geometry (list ,@geometry)))
	       ,@default-initargs))
cer's avatar
cer committed
	   ,@(when command-definer
	       `((defmacro ,command-definer (command-name arguments &body body)
		   #+Genera (declare (zwei:indentation 1 3 2 1))
		   `(define-frame-command ,',(first command-table)
					  ,command-name ,arguments ,@body))
		 #+Genera (scl:defprop ,command-definer
				       define-command
				       zwei:definition-function-spec-type)
		 #+Genera (scl:defprop ,command-definer
				       remove-command
				       zwei:kill-definition)
		 #+Genera (scl:defprop ,command-definer
				       zwei:defselect-function-spec-finder
				       zwei:definition-function-spec-finder)))
	   ;;--- Need to handle DISABLED-COMMANDS properly, 
	   ;;--- which entails doing a COPY-LIST
	   (define-application-frame-1 ',name ',slots ,pane-constructors
cer's avatar
cer committed
				       :layouts ,layout-value
cer's avatar
cer committed
				       :top-level ',top-level
				       :command-table ',command-table
				       :disabled-commands ',disabled-commands)
	   #+Cloe-Runtime
	   (cloe:define-program ,name ()
	     :main ,name
	     :debugger-hook cloe-debugger-hook)
cer's avatar
 
cer committed
	   ,@(compute-generate-panes-code name pane panes layouts)
	   ',name))))))
cer's avatar
cer committed

cer's avatar
cer committed
#+Genera
(scl:defprop define-application-frame "CLIM Application Frame" si:definition-type-name)

;; For now each application frame has its own command table named after the application
cer's avatar
cer committed
(defmacro define-frame-command (command-table-name name-and-options arguments &body body)
cer's avatar
cer committed
  #+Genera (declare (zwei:indentation 2 3 3 1))
cer's avatar
cer committed
  (multiple-value-bind (command-name command-options)
      (decode-name-and-options name-and-options command-table-name)
    `(define-command (,command-name :command-table ,command-table-name ,@command-options)
cer's avatar
cer committed
	 ,arguments
       ,@body)))

#+Genera
(scl::defprop define-frame-command define-command zwei:definition-function-spec-type)
#+Genera
(scl:defun (:property define-frame-command zwei:definition-function-spec-finder) (bp)
  (zwei:defselect-function-spec-finder (zwei:forward-sexp bp 1 t)))
cer's avatar
cer committed

cer's avatar
cer committed
(defun warn-if-command-table-invalid (frame-name command-table)
  (cond ((not (and (listp command-table)
		   (symbolp (first command-table))
		   (oddp (length command-table))))
	 (warn "The ~S option for frame ~S, ~S, is invalid.~@
		It is supposed to be a list of a command table name followed by ~
		keyword/value pairs."
	       :command-table frame-name command-table))
	(t
	 (do* ((options (cdr command-table) (cddr options))
	       (keyword (first options) (first options))
	       (value (second options) (second options)))
	      ((null options))
	   (case keyword
	     (:inherit-from
	       (if (listp value)
		   (dolist (item value)
		     (unless (typep item '(or symbol command-table))
		       (warn "The ~S keyword in the ~S option for frame ~S~@
			      is followed by a list containing ~S, which is not a ~
			      command table nor a command table name."
			     :inherit-from :command-table frame-name item)))
		   (warn "The ~S keyword in the ~S option for frame ~S~@
			  is followed by ~S, which is not a list of command tables ~
			  or command table names."
			 :inherit-from :command-table frame-name value)))
	     (:menu
	       (if (listp value)
		   (dolist (clause value)
		     (unless (and (listp clause)
				  (>= (length clause) 3)
				  (oddp (length clause))
				  (stringp (first clause))
				  (member (second clause)
					  '(:command :function :menu :divider)))
		       (warn "The ~S keyword in the ~S option for frame ~S~@
			      is followed by a list of menu clauses containing~@
			      an invalid clause ~S."
			     :menu :command-table frame-name clause)))
		   (warn "The ~S keyword in the ~S option for frame ~S~@
			  is followed by ~S, which is not a list of menu clauses."
			 :menu :command-table frame-name value)))
cer's avatar
cer committed
	     (:inherit-menu)
cer's avatar
cer committed
	     (otherwise
	       (warn "The keyword ~S in the ~S option for frame ~S is invalid.~@
		      The valid keywords are ~S and ~S."
		     keyword :command-table frame-name :inherit-from :menu))))))) 
cer's avatar
cer committed

cer's avatar
cer committed
(defun compute-generate-panes-code (name code panes layouts)
cer's avatar
cer committed
  (if layouts
cer's avatar
cer committed
      (compute-complex-generate-panes-code name panes layouts)
cer's avatar
cer committed
      (compute-simple-generate-panes-code name code)))
cer's avatar
cer committed

(defun compute-simple-generate-panes-code (name code)
cer's avatar
cer committed
  (and code
cer's avatar
cer committed
       (let ((frame '#:frame)
	     (framem '#:framem))
	 `((defmethod generate-panes ((,framem standard-frame-manager) (,frame ,name))
	     (let ((*application-frame* ,frame))
	       (setf (frame-panes ,frame)
		     (frame-wrapper ,framem ,frame
		       (with-look-and-feel-realization (,framem ,frame)
			 ,code)))))))))
cer's avatar
cer committed

cer's avatar
cer committed
(defun compute-complex-generate-panes-code (name panes layouts)
cer's avatar
 
cer committed
  (check-type layouts list)
cer's avatar
cer committed
  (let ((frame '#:frame)
	(framem '#:framem))
    `((defmethod generate-panes ((,framem standard-frame-manager) (,frame ,name))
cer's avatar
cer committed
	(symbol-macrolet
cer's avatar
cer committed
	  ,(mapcar #'(lambda (pane-spec)
cer's avatar
cer committed
		       (destructuring-bind (name code &rest ignore) pane-spec
			 (declare (ignore code ignore))
cer's avatar
cer committed
			 `(,name (find-or-make-pane-named ,frame ',name))))
		   panes)
	  (let ((*application-frame* ,frame))
	    (setf (frame-panes ,frame)
		  (frame-wrapper ,framem ,frame
		    (with-look-and-feel-realization (,framem ,frame)
		      (ecase (frame-current-layout ,frame)
cer's avatar
cer committed
			,@(mapcar 
			    #'(lambda (layout-spec)
				(destructuring-bind (name panes &rest ignore) layout-spec
				  (declare (ignore ignore))
				  `(,name ,panes)))
			    layouts)))))))))))
cer's avatar
cer committed

cer's avatar
cer committed
(defun compute-pane-constructor-code (panes)
cer's avatar
 
cer committed
  (check-type panes list)
cer's avatar
cer committed
  `(list ,@(mapcar #'(lambda (pane-spec)
cer's avatar
cer committed
		       (destructuring-bind (name code &rest options) pane-spec
			 (setq code (canonicalize-pane-spec name code options))
cer's avatar
cer committed
			 `(list ',name
				#'(lambda (frame framem)
				    (with-look-and-feel-realization (framem frame)
				      ,code)))))
		   panes)))
cer's avatar
cer committed
   
cer's avatar
cer committed
(defun canonicalize-pane-spec (name code rest)
  (cond ((symbolp code)
cer's avatar
cer committed
	 (unless (getf rest :name)
	   (setf (getf rest :name) `',name))
	 (apply #'find-pane-class-constructor code rest))
cer's avatar
cer committed
	((null rest) code)
cer's avatar
cer committed
	(t
	 (error "Invalid pane specification: ~S"
		(list* name code rest)))))

cer's avatar
cer committed
(defmethod find-pane-class-constructor ((type t) &rest options)
cer's avatar
cer committed
  (declare (dynamic-extent options))
cer's avatar
cer committed
  (error "Unknown pane type ~S with options ~S" type options))

cer's avatar
cer committed

;;--- Extend this to default the options from the lambda list
cer's avatar
cer committed
(defmacro define-pane-type (type lambda-list &body body)
  `(defmethod find-pane-class-constructor ((type (eql ',type)) ,@lambda-list)
     ,@body))

cer's avatar
cer committed
(define-pane-type :title (&rest options)
cer's avatar
cer committed
  (declare (non-dynamic-extent options))
cer's avatar
cer committed
  `(make-clim-stream-pane
     :type 'title-pane
cer's avatar
cer committed
     ,@options
cer's avatar
cer committed
     :display-function 'display-title
cer's avatar
cer committed
     :display-after-commands nil
cer's avatar
cer committed
     :text-style (parse-text-style '(:sans-serif :bold :large))
     :scroll-bars nil
cer's avatar
cer committed
     :width :compute :height :compute
cer's avatar
 
cer committed
     :max-height :compute
cer's avatar
cer committed
     :end-of-page-action :allow 
     :end-of-line-action :allow))
cer's avatar
cer committed

colin's avatar
colin committed
(define-pane-type :command-menu (&rest options)
cer's avatar
cer committed
  (declare (non-dynamic-extent options))
colin's avatar
colin committed
  `(make-clim-stream-pane
     :type 'command-menu-pane
     ,@options
     :display-function `(display-command-menu :command-table ,(frame-command-table frame))
     :incremental-redisplay t
     :display-after-commands t
     :text-style *command-table-menu-text-style*
     :scroll-bars nil
     :width :compute :height :compute
     :end-of-page-action :allow 
     :end-of-line-action :allow))
cer's avatar
cer committed

cer's avatar
cer committed
(define-pane-type :interactor (&rest options &key (scroll-bars :vertical))
cer's avatar
cer committed
  (declare (non-dynamic-extent options))
cer's avatar
cer committed
  `(make-clim-interactor-pane
     ,@options
     :scroll-bars ,scroll-bars))
cer's avatar
cer committed

cer's avatar
cer committed
(define-pane-type :application (&rest options &key (scroll-bars :both))
cer's avatar
cer committed
  (declare (non-dynamic-extent options))
cer's avatar
cer committed
  `(make-clim-application-pane 
     ,@options
     :scroll-bars ,scroll-bars))
cer's avatar
cer committed

cer's avatar
cer committed
(define-pane-type :accept-values (&rest options &key (scroll-bars :vertical))
  (declare (non-dynamic-extent options))
cer's avatar
cer committed
  `(make-clim-stream-pane 
     :type 'accept-values-pane
     ,@options
cer's avatar
cer committed
     :display-after-commands :no-clear
cer's avatar
cer committed
     :scroll-bars ,scroll-bars
cer's avatar
cer committed
     :width :compute :height :compute
cer's avatar
cer committed
     :end-of-page-action :allow
     :end-of-line-action :allow))

cer's avatar
cer committed
(define-pane-type :pointer-documentation (&rest options)
cer's avatar
cer committed
  (declare (non-dynamic-extent options))
cer's avatar
cer committed
  `(make-clim-stream-pane
     :type 'pointer-documentation-pane
     ,@options
     :display-after-commands nil
     :text-style (parse-text-style '(:sans-serif :bold :normal))
     :scroll-bars nil
cer's avatar
cer committed
     :end-of-page-action :allow
cer's avatar
cer committed
     :end-of-line-action :allow))
cer's avatar
cer committed

cer's avatar
cer committed
(define-pane-type scroll-bar (&rest options)
cer's avatar
cer committed
  (declare (non-dynamic-extent options))
cer's avatar
cer committed
  `(make-pane 'scroll-bar ,@options))

cer's avatar
cer committed
(define-pane-type slider (&rest options)
cer's avatar
cer committed
  (declare (non-dynamic-extent options))
cer's avatar
cer committed
  `(make-pane 'slider ,@options))

cer's avatar
cer committed
(define-pane-type push-button (&rest options)
cer's avatar
cer committed
  (declare (non-dynamic-extent options))
cer's avatar
cer committed
  `(make-pane 'push-button ,@options))

cer's avatar
cer committed
(define-pane-type label-pane (&rest options)
cer's avatar
cer committed
  (declare (non-dynamic-extent options))
cer's avatar
cer committed
  `(make-pane 'label-pane ,@options))

cer's avatar
cer committed
(define-pane-type text-field (&rest options)
cer's avatar
cer committed
  (declare (non-dynamic-extent options))
cer's avatar
cer committed
  `(make-pane 'text-field ,@options))

cer's avatar
cer committed
(define-pane-type text-editor (&rest options)
cer's avatar
cer committed
  (declare (non-dynamic-extent options))
cer's avatar
cer committed
  `(make-pane 'text-editor ,@options))
cer's avatar
cer committed

cer's avatar
cer committed
(define-pane-type toggle-button (&rest options)
cer's avatar
cer committed
  (declare (non-dynamic-extent options))
cer's avatar
cer committed
  `(make-pane 'toggle-button ,@options))

cer's avatar
cer committed
(define-pane-type radio-box (&rest options)
cer's avatar
cer committed
  (declare (non-dynamic-extent options))
cer's avatar
cer committed
  `(make-pane 'radio-box ,@options))

cer's avatar
cer committed
(define-pane-type check-box (&rest options)
  (declare (non-dynamic-extent options))
  `(make-pane 'check-box ,@options))

(define-pane-type list-pane (&rest options)
  (declare (non-dynamic-extent options))
  `(make-pane 'list-pane ,@options))

(define-pane-type option-pane (&rest options)
  (declare (non-dynamic-extent options))
  `(make-pane 'option-pane ,@options))

colin's avatar
colin committed
(define-pane-type :menu-bar (&rest options &key command-table)
cer's avatar
cer committed
  (declare (non-dynamic-extent options))
colin's avatar
colin committed
  (with-keywords-removed (options options '(:command-table))
    `(make-pane 'menu-bar 
		,@options
		:command-table ,(or command-table
				    `(frame-command-table frame)))))
cer's avatar
cer committed

cer's avatar
cer committed

cer's avatar
cer committed
(defmethod find-or-make-pane-named ((frame standard-application-frame) name)
  (with-slots (all-panes pane-constructors) frame
    (second (or (assoc name all-panes)
cer's avatar
cer committed
		(let ((new-pane
			(list name 
			      (funcall (second (assoc name pane-constructors))
				       frame (frame-manager frame)))))
cer's avatar
cer committed
		  ;; Maintain ALL-PANES in the order the panes are created
		  (setq all-panes (nconc all-panes (list new-pane)))
cer's avatar
cer committed
		  new-pane)))))
cer's avatar
cer committed
 
cer's avatar
cer committed
(defmethod layout-frame ((frame standard-application-frame) &optional width height)
cer's avatar
cer committed
  (let ((panes (frame-panes frame))
	(*application-frame* frame))
cer's avatar
cer committed
    (when panes
cer's avatar
cer committed
      (clear-space-requirement-caches-in-tree panes)
cer's avatar
cer committed
      (multiple-value-bind (graft-width graft-height) 
	  (bounding-rectangle-size (graft frame))
	(cond ((and width height)
	       (minf width graft-width) 
	       (minf height graft-height))
	      (t
	       (let ((sr (compose-space panes)))
		 (setq width  (or width (space-requirement-width sr))
		       height (or height (space-requirement-height sr)))
		 ;;--- This fudge factor stuff looks dubious  --SWM
		 (let ((fudge-factor #+Allegro 0.9 #-Allegro 1))
		   (minf-or width (* graft-width fudge-factor))
		   (minf-or height (* graft-height fudge-factor)))))))
cer's avatar
cer committed
      ;;--- Don't bother with this if the size didn't change?
cer's avatar
cer committed
      (let ((top-sheet (or (frame-top-level-sheet frame) panes)))
	(if (and (sheet-enabled-p top-sheet)
cer's avatar
cer committed
		 (not (frame-resizable frame)))
cer's avatar
cer committed
	    (multiple-value-call #'allocate-space 
cer's avatar
cer committed
	      top-sheet (bounding-rectangle-size top-sheet)) 
	    (resize-sheet top-sheet width height))))))
cer's avatar
cer committed

cer's avatar
cer committed
(defvar *frame-layout-changing-p* nil)

cer's avatar
cer committed
(defmethod (setf frame-current-layout) (layout (frame standard-application-frame))
cer's avatar
cer committed
  (unless (or (eq (frame-current-layout frame) layout)
	      (null (frame-top-level-sheet frame)))
cer's avatar
cer committed
    (setq *frame-layout-changing-p* t)
cer's avatar
cer committed
    (setf (slot-value frame 'current-layout) layout)
cer's avatar
cer committed
    ;; First disown all the children
    (dolist (name-and-pane (slot-value frame 'all-panes))
      (let ((sheet (second name-and-pane)))
	(when (sheet-parent sheet)
	  (sheet-disown-child (sheet-parent sheet) sheet))))
    (dolist (child (sheet-children (frame-top-level-sheet frame)))
      (sheet-disown-child (frame-top-level-sheet frame) child))
    ;; Now we want to give it some new ones
    (generate-panes (frame-manager frame) frame)
    (let ((sheets (frame-panes frame)))
      (setf (sheet-enabled-p sheets) nil)
      (sheet-adopt-child (frame-top-level-sheet frame) sheets)
      (multiple-value-call #'layout-frame
	frame (bounding-rectangle-size (frame-top-level-sheet frame)))
      ;;--- Don't throw, just recompute stream bindings in a principled way
      (setf (sheet-enabled-p sheets) t))
    (note-frame-current-layout-changed (frame-manager frame) frame)
cer's avatar
 
cer committed
    (handler-case
        (throw 'layout-changed nil)
      (error () nil))))

(defmethod note-frame-current-layout-changed ((frame-manager standard-frame-manager) (frame t))
  nil)

cer's avatar
 
cer committed
(defun adjust-layout-requirements (frame layout)
  (when (frame-panes frame)
cer's avatar
cer committed
    (let ((layout-space-requirements 
cer's avatar
 
cer committed
	   (cddr (assoc layout (frame-layouts frame)))))
cer's avatar
cer committed
      (changing-space-requirements (:layout nil)
cer's avatar
 
cer committed
	(flet ((reset-sr (sheet)
		 (when (panep sheet)
		   (change-space-requirements-to-default sheet))))
cer's avatar
cer committed
	  (declare (dynamic-extent #'adjust-layout))
cer's avatar
 
cer committed
	  (map-over-sheets #'reset-sr (frame-panes frame))
	  (dolist (pane-and-sr layout-space-requirements)
	    (let ((name (car pane-and-sr)))
	      (let ((pane (or (get-frame-pane frame name :errorp nil)
			      (find-pane-named frame name))))
		(apply #'change-space-requirements pane (cdr pane-and-sr))))))))))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod frame-all-layouts ((frame standard-application-frame))
  (mapcar #'first (frame-layouts frame)))
		 
cer's avatar
cer committed
#+Genera (zwei:defindentation (make-application-frame 1 1))
cer's avatar
cer committed
(defun make-application-frame (frame-name &rest options 
			       &key frame-class
				    enable pretty-name
cer's avatar
cer committed
			            left top right bottom width height
cer's avatar
cer committed
				    (user-specified-position-p :unspecified)
cer's avatar
cer committed
 				    (user-specified-size-p :unspecified)
				    save-under
cer's avatar
cer committed
			       &allow-other-keys)
  (declare (dynamic-extent options))
  (check-type pretty-name (or null string))
  (when (null frame-class)
    (setq frame-class frame-name))
cer's avatar
cer committed
  (when (or left top right bottom width height)
cer's avatar
cer committed
    (when (getf options :geometry)
cer's avatar
cer committed
      (error "Cannot specify ~S and ~S, S, ~S, ~S, ~S, or ~S at the same time"
	     :geometry :left :top :right :bottom :width :height))
    (macrolet ((check-conflict (edge1 edge2 size)
		 `(cond 
cer's avatar
cer committed
		    ((and ,edge1 ,size)
		     (if ,edge2
			 (error "Cannot specify ~S, ~S, and ~S together" ,edge1 ,size ,edge2)
			 (setq ,edge2 (+ ,edge1 ,size))))
		    ((and ,edge2 ,size)
		     (if ,edge1
			 (error "Cannot specify ~S, ~S, and ~S together" ,edge2 ,size ,edge1)
			 (setq ,edge1 (+ ,edge2 ,size))))
		    ((and ,edge2 ,edge1)
		     (if ,size
			 (error "Cannot specify ~S, ~S, and ~S together" ,edge2 ,edge1 ,size)
			 (setq ,size (- ,edge2 ,edge1)))))))
cer's avatar
cer committed
      (check-conflict left right width)
      (check-conflict top bottom height))
cer's avatar
cer committed
    (setf (getf options :geometry)
cer's avatar
cer committed
	  (append (and left `(:left ,left))
		  (and top `(:top ,top))
cer's avatar
cer committed
		  (and width `(:width ,width))
		  (and height `(:height ,height)))))
cer's avatar
cer committed
  (let ((geometry (getf options :geometry)))
cer's avatar
cer committed
    (when (and (eq user-specified-position-p :unspecified)
	       (or (and (getf geometry :left)
			(getf geometry :top))
		   (and left top)))
      (setf user-specified-position-p t))
    (when (and (eq user-specified-size-p :unspecified)
	       (or (and (getf geometry :width)
			(getf geometry :height))
		   (and width height)))
      (setf user-specified-size-p t)))
cer's avatar
cer committed
  (with-keywords-removed (options options 
cer's avatar
cer committed
			  '(:frame-class :pretty-name :enable :save-under
cer's avatar
cer committed
			    :left :top :right :bottom :width :height
cer's avatar
cer committed
			    :user-specified-position-p :user-specified-size-p))
cer's avatar
cer committed
    (let ((frame (apply #'make-instance
			frame-class
			:name frame-name
			;;--- Perhaps this should be a default-initarg?
			:pretty-name (or pretty-name
					 (title-capitalize (string frame-name)))
			:properties `(:save-under ,save-under)
			:user-specified-size-p user-specified-size-p
			:user-specified-position-p user-specified-position-p
			options)))
      (when enable 
	(enable-frame frame))
      frame)))

cer's avatar
cer committed
;; Create an application frame of the specified type if one does not already
;; exist, and then run it, possibly in its own process.  If one already exists,
;; just select it.
cer's avatar
cer committed
(defun find-application-frame (frame-name &rest initargs
cer's avatar
cer committed
			       &key (create t) (activate t) 
				    (own-process *multiprocessing-p*)
cer's avatar
cer committed
				    frame-class
			       &allow-other-keys)
  (declare (dynamic-extent initargs))
cer's avatar
cer committed
  (when (null frame-class)
    (setq frame-class frame-name))
  (let ((frame
cer's avatar
cer committed
	  (unless (eq create :force)
	    (block find-frame
	      (map-over-frames #'(lambda (frame)
				   (when (typep frame frame-class)
				     (return-from find-frame frame))))))))
    (when (and create (null frame))
      (with-keywords-removed (initargs initargs '(:create :activate :own-process))
	(setq frame (apply #'make-application-frame frame-name initargs))))
cer's avatar
cer committed
    (when (and frame activate)
      (cond ((slot-value frame 'top-level-process)
	     (raise-frame frame))
	    (own-process
	     (make-process #'(lambda () (run-frame-top-level frame))
			   :name (frame-pretty-name frame)))
	    (t
	     (run-frame-top-level frame))))
    frame))

cer's avatar
cer committed
(defmethod enable-frame ((frame standard-application-frame))
cer's avatar
cer committed
  (unless (frame-manager frame)
cer's avatar
cer committed
    (error "Cannot enable a disowned frame ~S" frame))
cer's avatar
cer committed
  (destructuring-bind (&key left top width height &allow-other-keys)
cer's avatar
cer committed
      (frame-geometry frame)
cer's avatar
cer committed
    (ecase (frame-state frame)
      (:enabled)
      ((:disabled :disowned)
cer's avatar
cer committed
       (let ((old-state (frame-state frame)))
cer's avatar
cer committed
	 (setf (frame-state frame) :enabled)
cer's avatar
cer committed
	 ;; If this is a new frame then if the user specified a width
cer's avatar
cer committed
	 ;; then we should be using that
cer's avatar
cer committed
	 ;; If the frame already exists then we probably should be using
cer's avatar
cer committed
	 ;; the top level sheet size
cer's avatar
cer committed
	 (multiple-value-bind (width height)
	     (ecase old-state
cer's avatar
cer committed
	       (:disowned 
cer's avatar
cer committed
		 (if (and width height)
		     (values width height)
		     (values)))
cer's avatar
cer committed
	       (:disabled
cer's avatar
cer committed
		 (bounding-rectangle-size
		   (frame-top-level-sheet frame))))  
	   (layout-frame frame width height)
cer's avatar
cer committed
	   (when (and left top)
	     (move-sheet (frame-top-level-sheet frame) left top))
cer's avatar
cer committed
	   (note-frame-enabled (frame-manager frame) frame))))
      (:shrunk 
        (note-frame-deiconified (frame-manager frame) frame)))))
cer's avatar
cer committed

cer's avatar
 
cer committed
(defmethod shrink-frame ((frame standard-application-frame))
cer's avatar
cer committed
  (note-frame-iconified (frame-manager frame) frame))

cer's avatar
cer committed
(defmethod destroy-frame ((frame standard-application-frame))
  (when (eq (frame-state frame) :enabled)
    (disable-frame frame))
  (disown-frame (frame-manager frame) frame))

cer's avatar
cer committed
(defmethod disable-frame ((frame standard-application-frame))
cer's avatar
cer committed
  (ecase (frame-state frame)
cer's avatar
cer committed
    ((:disowned :disabled))
cer's avatar
cer committed
    ((:enabled :shrunk)
     (setf (frame-state frame) :disabled)
     (note-frame-disabled (frame-manager frame) frame))))

cer's avatar
cer committed
(defmethod reset-frame ((frame standard-application-frame) &rest ignore)
  (declare (ignore ignore))
  nil)
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod raise-frame ((frame standard-application-frame))
  (raise-sheet (frame-top-level-sheet frame)))

(defmethod bury-frame ((frame standard-application-frame))
  (bury-sheet (frame-top-level-sheet frame)))

(defmethod note-frame-enabled 
	   ((framem standard-frame-manager) (frame standard-application-frame))
  )

(defmethod note-frame-disabled 
	   ((framem standard-frame-manager) (frame standard-application-frame))
  )

(defmethod note-frame-iconified 
	   ((framem standard-frame-manager) (frame standard-application-frame))
cer's avatar
cer committed
  )

cer's avatar
cer committed
(defmethod note-frame-deiconified
	   ((framem standard-frame-manager) (frame standard-application-frame))
cer's avatar
cer committed
  )
cer's avatar
cer committed

cer's avatar
cer committed

cer's avatar
cer committed
(defmethod port-note-frame-adopted ((port basic-port) (frame standard-application-frame))
  nil)


cer's avatar
cer committed
(defmethod (setf frame-pretty-name) :before (name (frame standard-application-frame))
  (check-type name string))
cer's avatar
cer committed
(defmethod (setf frame-pretty-name) :after (name (frame standard-application-frame))
  (declare (ignore name))
  (let ((framem (frame-manager frame)))
    (when framem (frame-manager-note-pretty-name-changed framem frame))))

(defmethod frame-manager-note-pretty-name-changed ((framem standard-frame-manager) 
						   (frame standard-application-frame))
  nil)

cer's avatar
cer committed

(eval-when (#-Allegro compile load eval)
cer's avatar
 
cer committed
(define-condition frame-exit (condition)
  ((frame :initarg :frame :reader frame-exit-frame))
  (:report (lambda (condition stream)
	     (format stream "Exit from frame ~A" (frame-exit-frame condition)))))
cer's avatar
cer committed
)	;eval-when
cer's avatar
cer committed
(defgeneric run-frame-top-level (frame &key &allow-other-keys))

cer's avatar
cer committed
;; Reset the state of the input editor and the presentation type system,
;; etc., in case there is an entry into another application from inside
;; the input editor, such as a Debugger written using CLIM.
(defmacro with-clim-state-reset ((&key all 
				       (encapsulating-streams all)
				       (presentation-types all)
				       (input-editor all)
				       (frames all)
				       (command-processor all)
				       additional-bindings) &body body)
  `(let (,@(when encapsulating-streams
	     `((*original-stream* nil)))
	 ,@(when presentation-types
	     `((*input-wait-test* nil)
	       (*input-wait-handler* nil)
	       (*pointer-button-press-handler* nil)
	       (*input-context* nil)))
	 ,@(when input-editor
	     `((*numeric-argument* nil)
	       (*delimiter-gestures* nil)
	       (*activation-gestures* nil)
	       (*accelerator-gestures* nil)
	       (*accelerator-numeric-argument* nil)
	       (*accept-help* nil)))
	 ,@(when frames
	     `((*assume-all-commands-enabled* nil)
	       (*sizing-application-frame* nil)
	       (*frame-layout-changing-p* *frame-layout-changing-p*)))
	 ,@(when command-processor
	     `((*command-parser* 'command-line-command-parser)
	       (*command-unparser* 'command-line-command-unparser)
	       (*partial-command-parser* 
		 'command-line-read-remaining-arguments-for-partial-command)))
	 ,@additional-bindings)
     ,@body))

cer's avatar
cer committed
;;--- It would be nice to have the CLIM 0.9 START-FRAME and STOP-FRAME functions
cer's avatar
cer committed
(defmethod run-frame-top-level :around ((frame standard-application-frame) &key)
cer's avatar
cer committed
  (with-simple-restart (nil "Exit ~A" (frame-pretty-name frame))
    (handler-bind ((frame-exit
		     #'(lambda (condition)
			 (let ((exit-frame (frame-exit-frame condition)))
			   (when (eq frame exit-frame)
			     (return-from run-frame-top-level nil))))))
      (unwind-protect
cer's avatar
cer committed
	  (with-clim-state-reset (:all t
				  :additional-bindings ((*application-frame* frame)))
cer's avatar
cer committed
	    (with-frame-manager ((frame-manager frame))
	      (loop
		(with-simple-restart (nil "~A top level" (frame-pretty-name frame))
		  (loop
		    (catch 'layout-changed
		      (let ((*application-frame* frame))
			;; We must return the values from CALL-NEXT-METHOD,
			;; or else ACCEPTING-VALUES will return NIL
			#-CCL-2
			(return-from run-frame-top-level (call-next-method))
			;; The (RETURN-FROM FOO (CALL-NEXT-METHOD)) form above
			;; doesn't work in Coral.  If the "top level" restart
			;; above is taken, the CALL-NEXT-METHOD form blows out
			;; the second time through this code, claiming that it
			;; can't find the next method.  Hoisting the
			;; CALL-NEXT-METHOD out of the RETURN-FROM form seems
			;; to fix it...  So it conses, big deal.
			#+CCL-2
			(let ((results (multiple-value-list (call-next-method))))
			  (return-from run-frame-top-level (values-list results))))))))))
	;; We disable the frame here, but it is the responsibility of the
	;; top-level function to enable the frame.  For example, if we
	;; called ENABLE-FRAME here, ACCEPTING-VALUES would disable the
	;; wrong frame.  Sigh.
	(queue-flush (frame-command-queue frame))
cer's avatar
 
cer committed
	(let ((sheet (frame-top-level-sheet frame)))
	  (when sheet (queue-flush (sheet-event-queue sheet))))
cer's avatar
cer committed
	(disable-frame frame)))))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod run-frame-top-level ((frame standard-application-frame) &rest args)
  (declare (dynamic-extent args))
cer's avatar
cer committed
  (with-slots (top-level-process) frame
    (when top-level-process
      (cerror "Bludgeon ahead, assuming the risk"
	      "The process ~S is already running the top-level function for frame ~S"
	      top-level-process frame))
    (unwind-protect
cer's avatar
cer committed
	(let* ((top-level (frame-top-level frame))
	       (tl-function (if (listp top-level) (first top-level) top-level))
	       (tl-args (if (listp top-level) (rest top-level) nil)))
cer's avatar
cer committed
	  (setq top-level-process (current-process))
cer's avatar
cer committed
	  ;; Cons as little as possible
	  (cond ((and (null args) (null tl-args))
		 (funcall tl-function frame))
		((null tl-args)
		 (apply tl-function frame args))
		((null args)
		 (apply tl-function frame tl-args))
		(t
		 (apply tl-function frame (append args tl-args)))))
cer's avatar
cer committed
      (setq top-level-process nil))))
cer's avatar
cer committed

cer's avatar
 
cer committed
;;; Update demo/default-frame-top-level.lisp if you change this
;;--- I'm not really convinced that this is right  --SWM
;;-- refers  to the choice of command-stream

cer's avatar
cer committed
(defmethod default-frame-top-level ((frame standard-application-frame)
				    &key command-parser command-unparser
				    partial-command-parser
				    (prompt "Command: "))
cer's avatar
cer committed
  ;; Enable the frame now
cer's avatar
cer committed
  (unless (eq (frame-state frame) :enabled)
    (enable-frame frame))
cer's avatar
cer committed
  (loop
cer's avatar
cer committed
    (let* ((*standard-output*
	    (or (frame-standard-output frame) *standard-output*))
cer's avatar
cer committed
	   (*standard-input* 
	    (or (frame-standard-input frame) *standard-output*))
cer's avatar
cer committed
	   (*query-io* 
	    (or (frame-query-io frame) *standard-input*))
cer's avatar
cer committed
	   (*error-output* 
	    (or (frame-error-output frame) *standard-output*))
cer's avatar
cer committed
	   (*pointer-documentation-output*
	    (frame-pointer-documentation-output frame))
cer's avatar
cer committed
	   (interactor
	    (not (null (find-frame-pane-of-type frame 'interactor-pane))))
cer's avatar
cer committed
	   (*command-parser*
	    (or command-parser
		(if interactor
		    #'command-line-command-parser
		  #'menu-command-parser)))
cer's avatar
cer committed
	   (*command-unparser*
	    (or command-unparser 
		#'command-line-command-unparser))
cer's avatar
cer committed
	   (*partial-command-parser* 
	    (or partial-command-parser
		(if interactor
		    #'command-line-read-remaining-arguments-for-partial-command
		  #'menu-read-remaining-arguments-for-partial-command)))
cer's avatar
cer committed
	   (command-stream
	    ;;--- We have to ask the frame since we do not want to
	    ;;--- just pick up a stream from the dynamic environment
	    (let ((si (or (frame-standard-input frame)
			  (frame-standard-output frame))))
	      (typecase si
		(output-protocol-mixin si)
		(t (frame-top-level-sheet frame))))))
cer's avatar
cer committed
      ;; The read-eval-print loop for applications...
      (letf-globally (((frame-actual-pointer-documentation-pane frame) *pointer-documentation-output*))
	(loop
	  ;; Redisplay all the panes
	  (catch-abort-gestures ("Return to ~A command level" (frame-pretty-name frame))
	    (redisplay-frame-panes frame)
cer's avatar
cer committed
	    (when interactor
	      (fresh-line *standard-input*)
	      (if (stringp prompt)
		  (write-string prompt *standard-input*)
		(funcall prompt *standard-input* frame)))
	    (let ((command (read-frame-command frame :stream command-stream)))
	      (when interactor
		(terpri *standard-input*))
	      ;; Need this check in case the user aborted out of a command menu
	      (when command
		(execute-frame-command frame command)))))))))
cer's avatar
cer committed

cer's avatar
cer committed
;; Generic because someone might want :BEFORE or :AFTER
(defmethod frame-exit ((frame standard-application-frame))
cer's avatar
 
cer committed
  (signal 'frame-exit :frame frame))
cer's avatar
cer committed

cer's avatar
cer committed

(defmethod handle-event ((stream input-protocol-mixin) (event port-terminated))
  (if (pane-frame stream)
      (frame-terminated (pane-frame stream) event)
      (error "Port has died: ~A" event)))

(defmethod frame-terminated ((frame standard-application-frame) event)
  (error "Port for frame ~A has died: ~A" frame event))

cer's avatar
cer committed

;;; Sizing and moving of frames

;; Sizes an application frame based on the size of the contents of the 
;; output recording stream STREAM.
(defun size-frame-from-contents (stream 
				  &key width height
				       (right-margin 10) (bottom-margin 10)
				       (size-setter #'window-set-inside-size))
  (with-slots (output-record) stream
    (with-bounding-rectangle* (left top right bottom) output-record
      (let* ((graft (or (graft stream)
			(find-graft)))		;--- is this right?
	     (gw (bounding-rectangle-width (sheet-region graft)))
	     (gh (bounding-rectangle-height (sheet-region graft)))
	     ;;--- Does this need to account for the size of window decorations?
	     (width (min gw (+ (or width (- right left)) right-margin)))
	     (height (min gh (+ (or height (- bottom top)) bottom-margin))))
	;; The size-setter will typically resize the entire frame
	(funcall size-setter stream width height)
	(window-set-viewport-position stream left top)))))

;; Moves the sheet to the specified position, taking care not to move
;; it outside of the graft.  It's safest to use this on a top-level sheet.
(defun position-sheet-carefully (sheet x y)
  (multiple-value-bind (width height) (bounding-rectangle-size sheet)
    (multiple-value-bind (graft-width graft-height)
	(bounding-rectangle-size (or (graft sheet) (find-graft)))
      (let* ((left x)
	     (top y)
	     (right (+ left width))
	     (bottom (+ top height)))
	(when (> right graft-width)
	  (setq left (- graft-width width)))
	(when (> bottom graft-height)
	  (setq top (- graft-height height)))
cer's avatar
 
cer committed
	(port-move-frame (port sheet) (pane-frame sheet) (max 0 left) (max 0 top))))))

(defmethod port-move-frame ((port basic-port) frame x y)
  (move-sheet (frame-top-level-sheet frame) x y))
cer's avatar
cer committed

;; Moves the sheet to be near where the pointer is.  It's safest to use this
;; on a top-level sheet.
(defun position-sheet-near-pointer (sheet &optional x y)
  (unless (and x y)
    (multiple-value-setq (x y)
      (pointer-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

#+ignore
(defmethod pane-name ((pane basic-pane))
  (let ((frame (pane-frame pane)))
    (and frame
	 (dolist (name-and-pane (slot-value frame 'all-panes))
	   (destructuring-bind (name apane) name-and-pane
	     (when (sheet-ancestor-p pane apane)
	       (return name)))))))

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 (skip-pane-redisplay "Skip redisplaying pane ~S" pane)
cer's avatar
cer committed
      (loop
	(with-simple-restart (retry-pane-redisplay "Retry displaying pane ~S" pane)
cer's avatar
cer committed
	  (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

(defmethod command-defined-p ((frame standard-application-frame) command)
  (or (not (symbolp command))
      (fboundp command)))

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 (command-defined-p frame command-name)
	     (not (member command-name disabled-commands))
cer's avatar
cer committed
	     (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)
   (echo :initarg :echo :reader synchronous-command-event-echo-p))
cer's avatar
cer committed
  (: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)
  (flet ((maybe-echo-command (command)
	   (let ((ptype `(command :command-table ,(frame-command-table frame))))
	     (when (eq *command-parser* #'command-line-command-parser)
	       (present command ptype :stream *standard-input* :allow-sensitive-inferiors nil))
	     (when (frame-maintain-presentation-histories frame)
	       (push-history-element (presentation-type-history ptype)
				     (make-presentation-history-element :object command :type ptype))))))
    (let* ((command-and-options (queue-pop (frame-command-queue frame))))
      (if command-and-options
	  (destructuring-bind (command &key echo) command-and-options
	    (when echo (maybe-echo-command command))
	    command)
cer's avatar
cer committed
	(handler-bind ((synchronous-command-event
			#'(lambda (c)
			    (let ((command (synchronous-command-event-command c)))
			      (when (synchronous-command-event-echo-p c)
				(maybe-echo-command command))
			      (return-from read-frame-command command)))))
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)
     (echo :initarg :echo :initform t :reader presentation-event-echo-p)
cer's avatar
cer committed
     (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
		    :echo (presentation-event-echo-p event)
cer's avatar
cer committed
		    :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)
				   (presentation-event-echo-p event))
cer's avatar
cer committed
	      (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))))))
		  
(defun queue-frame-command (frame command &optional (echo t))
  (queue-push (frame-command-queue frame) (list command :echo echo)))
cer's avatar
cer committed

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
	    :echo  nil
	    :queuep t
	    :presentation-type `(command :command-table ,command-table))))
cer's avatar
cer committed
    (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*
    #-makes-things-fail 0
    #+makes-things-fail
    (max (floor (* 1/10 internal-time-units-per-second)) 1))

(setq *pointer-documentation-interval* 0)
cer's avatar
cer committed
(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)))