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

;; $Header: /repo/cvs.copy/clim2/clim/frames.lisp,v 1.86 1997/09/03 04:03:27 tomj 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)
     (background :initform nil :initarg :background :accessor frame-background)
     (foreground :initform nil :initarg :foreground :accessor frame-foreground)
     (text-style :initform nil :initarg :text-style :accessor frame-text-style)
     (command-table :initarg :command-table
                    :initform (find-command-table 'user-command-table)
                    :accessor frame-command-table)
cer's avatar
cer committed
     (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)
     (state :initform :disowned :accessor frame-state
            :type (member :disowned :disabled :enabled :shrunk))
cer's avatar
cer committed
     (top-level :initarg :top-level  :accessor frame-top-level)
     (current-layout :initarg :default-layout :initform nil
                     :reader frame-current-layout)
cer's avatar
cer committed
     (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)
cer's avatar
cer committed
     (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)
cer's avatar
cer committed
     (properties :initform nil :initarg :properties
cer's avatar
cer committed
     (resizable :initarg :resize-frame
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
                     :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)))
        (t (find-frame-manager))))
cer's avatar
cer committed

(defmethod frame-manager ((graft graft))
  (find-frame-manager :port (port graft)))

(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))))))
#+(or aclpc acl86win32) ;; pr Aug97
(defun clean-frame (frame)
  ;; (disable-frame frame)
  ;; (enable-frame frame)
  nil)

#+(or aclpc acl86win32) ;; pr Aug97
(defun frame-find-position (frame)
  (when frame 
    (let ((wrect (ct::ccallocate win::rect))
          (handle (sheet-mirror (frame-top-level-sheet frame))))
      (win::GetWindowRect handle wrect)
      (values (ct::cref win::rect wrect win::left) 
              (ct::cref win::rect wrect win::top)))))

#+(or aclpc acl86win32) ;; pr Aug97
(defun frame-set-position (frame x y)
  (win::setWindowPos (sheet-mirror (frame-top-level-sheet frame))
     (ct::null-handle win::hwnd) ; we really want win::HWND_TOP
     x y 0 0
     (logior win::swp_noactivate
	     win::swp_nozorder
	     win::swp_nosize)))

(defmethod color-stream-p ((stream stream))
  nil)

(defmethod color-stream-p ((stream standard-encapsulating-stream))
  (color-stream-p (encapsulating-stream-stream stream)))

(defmethod color-stream-p ((stream basic-extended-output-protocol))
  (let* ((frame (pane-frame stream))
         (palette (if frame
                      (frame-palette frame)
                    (port-default-palette (port stream)))))
    (palette-color-p palette)))
cer's avatar
 
cer committed

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))
cer's avatar
 
cer committed
  (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
                                   &key top-level layouts
                                        command-table)
  (declare (ignore name state-variables pane-descriptions top-level
  ;; 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

;; The recoginized options for define-application-frame are
;; :pane :panes :layouts :top-level :menu-bar :pointer-documentation
;; :command-definer :command-table :disabled-commands
;; :default-initargs :icon :geometry. All other options are passed on
;; as class options to defclass

cer's avatar
cer committed
(defmacro define-application-frame (name superclasses slots &rest options)
cer's avatar
cer committed
  (with-warnings-for-definition name define-application-frame
cer's avatar
cer committed
    (let (pane panes layouts top-level menu-bar pointer-documentation
          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)
                                           options (delete entry options)))))))))
        (extract pane :pane nil)
        (extract panes :panes nil nil)
        (extract layouts :layouts nil nil)
        (extract top-level :top-level '(default-frame-top-level))
        (extract menu-bar :menu-bar t)
        (extract pointer-documentation :pointer-documentation nil)
        (extract command-definer :command-definer t)
        (extract command-table :command-table t)
        (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)
      (check-type geometry list)
      (check-type default-initargs list)
      (when (and pane (or panes layouts))
        (error "The ~S option is mutually exclusive with the ~S and ~S options"
               :pane :panes :layouts))
cer's avatar
cer committed
      (when (null superclasses)
        (setq superclasses '(standard-application-frame)))
cer's avatar
cer committed
      (when (eq command-definer 't)
        (setq command-definer (fintern "~A-~A-~A" 'define name 'command)))
cer's avatar
cer committed
      (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)))
cer's avatar
cer committed
      (when (eq (first command-table) 't)
        (setq command-table (list* name (rest command-table))))
      (let ((pane-constructors
             (cond (panes
                    (compute-pane-constructor-code panes))
                   (pane
                    (compute-pane-constructor-code `((,name ,pane))))))
            (layout-value
             `(list ,@(mapcar
                       #'(lambda (layout)
                           (destructuring-bind (name pane &rest sizes) layout
                             (check-type sizes list)
                             (if sizes
                                 `(list ',name ',pane
                                        ,@(mapcar
                                           #'(lambda (pane-and-size)
                                               (destructuring-bind (pane &rest sizes)
                                                   pane-and-size
                                                 `(list ',pane ,@sizes)))
                                           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
                                       :layouts ,layout-value
                                       :top-level ',top-level
                                       :command-table ',command-table))
         (define-group ,name define-application-frame
           (defclass ,name ,superclasses ,slots
             ,@options
             (:default-initargs
               :layouts ,layout-value
               :menu-bar ',menu-bar
               :pointer-documentation ',pointer-documentation
               ,@(and command-table `(:command-table ',(car command-table)))
               ,@(and top-level `(:top-level ',top-level))
               ,@(and panes `(:pane-constructors ,pane-constructors))
               ,@(and layouts `(:default-layout ',(caar layouts)))
               ,@(and icon `(:icon (list ,@icon)))
               ,@(and geometry `(:geometry (list ,@geometry)))
               ,@(and disabled-commands
                      `(:disabled-commands (copy-list ',disabled-commands)))
               ,@default-initargs))
           ,@(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)))
           (define-application-frame-1 ',name ',slots ,pane-constructors
                                       :layouts ,layout-value
                                       :top-level ',top-level
                                       :command-table ',command-table)
           #+Cloe-Runtime
           (cloe:define-program ,name ()
             :main ,name
             :debugger-hook cloe-debugger-hook)
           ,@(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
       ,@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)))
             (:inherit-menu)
             (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

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

(defun compute-simple-generate-panes-code (name code)
    `((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)
cer's avatar
cer committed
    `((defmethod generate-panes ((,framem standard-frame-manager) (,frame ,name))
        (symbol-macrolet
          ,(mapcar #'(lambda (pane-spec)
                       (destructuring-bind (name &rest ignore) pane-spec
                         (declare (ignore ignore))
                         `(,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)
                        ,@(mapcar
                            #'(lambda (layout-spec)
                                (destructuring-bind (name pane &rest ignore) layout-spec
                                  (declare (ignore ignore))
                                  `(,name ,pane)))
                            layouts)))))))))))
cer's avatar
cer committed

(defun compute-default-generate-panes-code (name panes)
  (let ((frame '#:frame)
    `((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)
                (vertically ()
                  ,@(mapcar #'(lambda (pane-spec)
                                (destructuring-bind (name &rest ignore) pane-spec
                                  (declare (ignore ignore))
                                  `(find-or-make-pane-named ,frame ',name)))
                            panes))))))))))
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)
                (let ((new-pane
                        (list name
                              (funcall (second (assoc name pane-constructors))
                                       frame (frame-manager frame)))))
                  ;; Maintain ALL-PANES in the order the panes are created
                  (setq all-panes (nconc all-panes (list new-pane)))
                  new-pane)))))
(defmethod make-all-panes ((frame standard-application-frame))
  (with-slots (pane-constructors) frame
    (dolist (x pane-constructors)
      (find-or-make-pane-named frame (car x)))))

;; Many window managers will negotiate correctly with the toolkit to
;; limit frames to the screen size. For those that don't (notably olwm)
;; *graft-maximum-size-factor* allows you to control how much of graft
;; to use. Setting it some value less than 1 will allow you to see the
;; window manager decoration (which CLIM can't know the size of)
;; cim 7/12/96

;; Perhaps this should be a slot in the graft and not set globally

(defvar *graft-maximum-size-factor* nil)

(defmacro limit-size-to-graft (width height graft)
  `(multiple-value-bind (graft-width graft-height)
       (bounding-rectangle-size ,graft)
     ;;--- This fudge factor stuff looks dubious  --SWM
     (let ((fudge-factor (or *graft-maximum-size-factor* 1)))
       (minf-or ,width (* graft-width fudge-factor))
       (minf-or ,height (* graft-height fudge-factor)))))

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))
cer's avatar
cer committed
    (when panes
cer's avatar
cer committed
      (clear-space-requirement-caches-in-tree panes)
      (unless (and width height)
        (let ((sr (compose-space panes)))
          (setq width  (or width (space-requirement-width sr))
                height (or height (space-requirement-height sr))))
	(limit-size-to-graft width height (graft frame)))
cer's avatar
cer committed
      ;;--- Don't bother with this if the size didn't change?
      ;; +++rl consider making frame-resizable t the default instead
cer's avatar
cer committed
      (let ((top-sheet (or (frame-top-level-sheet frame) panes)))
        (if #+(or aclpc acl86win32) nil
            #-(or aclpc acl86win32) (and (sheet-enabled-p top-sheet)
                         (not (frame-resizable frame)))
            (multiple-value-call #'allocate-space 
              top-sheet 
              ;;mm: This should be the usable (client) size in all cases
              (bounding-rectangle-size top-sheet)) 
          (resize-sheet top-sheet width height))))))
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))))
cer's avatar
cer committed
    (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
        (if (frame-resizable frame)
            (values)
          (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-layout-changed (frame-manager frame) frame)
cer's avatar
 
cer committed
    (handler-case
        (throw 'layout-changed nil)
      (error () nil))))

(defmethod note-frame-layout-changed ((frame-manager standard-frame-manager) (frame t))
cer's avatar
 
cer committed
(defun adjust-layout-requirements (frame layout)
  (when (frame-panes frame)
    (let ((layout-space-requirements
           (cddr (assoc layout (frame-layouts frame)))))
cer's avatar
cer committed
      (changing-space-requirements (:layout nil)
        (flet ((reset-sr (sheet)
                 (when (panep sheet)
                   (change-space-requirements-to-default sheet))))
          (declare (dynamic-extent #'adjust-layout))
          (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))
(defun make-application-frame (frame-name &rest options
                               &key frame-class
                                    enable pretty-name
                                    left top right bottom width height
                                    (user-specified-position-p :unspecified)
                                     (user-specified-size-p :unspecified)
                                    save-under
                               &allow-other-keys)
cer's avatar
cer committed
  (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))
cer's avatar
cer committed
    (macrolet ((check-conflict (edge1 edge2 size)
                 `(cond
                    ((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)
          (append (and left `(:left ,left))
                  (and top `(:top ,top))
                  (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))
                   #+(or aclpc acl86win32) (and left top)             ;mm: ???
                   ))
cer's avatar
cer committed
      (setf user-specified-position-p t))
    (when (and (eq user-specified-size-p :unspecified)
               (or (and (getf geometry :width)
                        (getf geometry :height))
                   #+(or aclpc acl86win32) (and width height)           ;mm: ???
                   ))
cer's avatar
cer committed
      (setf user-specified-size-p t)))
  (with-keywords-removed (options options 
                          '(:frame-class :pretty-name :enable :save-under
                            :left :top :right :bottom :width :height
                            :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)))
cer's avatar
cer committed
      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
                               &key (create t) (activate t)
                                    (own-process *multiprocessing-p*)
                                    frame-manager port
                                    frame-class
                               &allow-other-keys)
cer's avatar
cer committed
  (declare (dynamic-extent initargs))
cer's avatar
cer committed
  (when (null frame-class)
    (setq frame-class frame-name))
  (let ((frame
          (unless (eq create :force)
            (block find-frame
              (map-over-frames #'(lambda (frame)
                                   (when (typep frame frame-class)
                                     (return-from find-frame frame)))
                               :frame-manager frame-manager
                               :port port)
              nil))))
cer's avatar
cer committed
    (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))))
cer's avatar
cer committed
    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)
    (let ((old-state (frame-state frame)))
      (ecase old-state
        (:enabled)
        ((:disabled :disowned)
         ;; If this is a new frame then if the user specified a width
         ;; then we should be using that
         ;; If the frame already exists then we probably should be using
         ;; the top level sheet size
         (multiple-value-bind (width height)
             (ecase old-state
               (:disowned
                (values width height))
               (:disabled
                (bounding-rectangle-size
                 (frame-top-level-sheet frame))))
           (layout-frame frame width height)
           (when (and left top)
             (position-sheet-carefully (frame-top-level-sheet frame) left top))
           (note-frame-enabled (frame-manager frame) frame)))
        (:shrunk
         (note-frame-deiconified (frame-manager frame) frame)))))
  (setf (frame-state frame) :enabled))
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))
cer's avatar
cer committed
  )

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

(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))
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)))))
)        ;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)
cer's avatar
cer committed
  `(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)
cer's avatar
cer committed
     ,@body))

#+(or aclpc acl86win32); unqualified first
(defmethod run-frame-top-level ((frame standard-application-frame) &rest args)
  (declare (dynamic-extent args))
  (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
        (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)))
          (setq top-level-process (current-process))
          ;; 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)))))
      (setq top-level-process nil))))

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))))))
cer's avatar
cer committed
      (unwind-protect
          (with-clim-state-reset (:all t
                                  :additional-bindings ((*application-frame* frame)))
            (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))
        (let ((sheet (frame-top-level-sheet frame)))
          (when sheet (queue-flush (sheet-event-queue sheet))))
        (disable-frame frame)))))

#-(or aclpc acl86win32)
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))
cer's avatar
cer committed
    (unwind-protect
        (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)))
          (setq top-level-process (current-process))
          ;; 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: "))
  (let #-(or aclpc acl86win32) ()
       #+(or aclpc acl86win32) (orig-x orig-y new-x new-y)
    #-(or aclpc acl86win32) ;; Enable the frame now
    (unless (eq (frame-state frame) :enabled)
      (enable-frame frame))
    #+(or aclpc acl86win32) ;; pr Aug97
    ;;--- looks like he wants to do the ugly growing far off-screen
    ;;--- and then move the window back in.  Hacky but effective. -tjm
    (unless (eq (frame-state frame) :enabled)
      (multiple-value-setq (orig-x orig-y) (frame-find-position frame))
      (when (and orig-x orig-y)
        (frame-set-position frame (+ orig-x 10000) (+ orig-y 10000)))
      ;;(move-sheet (frame-top-level-sheet frame) (+ orig-x 10000) (+ orig-y 10000))
      (multiple-value-setq (new-x new-y) (frame-find-position frame))
      (when (and orig-x orig-y new-x new-y 
                 (not (= new-x (+ orig-x 10000))) (not (= new-y (+ orig-y 10000))))
        (frame-set-position frame orig-x orig-y)
        (setf new-x nil new-y nil))
      (enable-frame frame))
    (loop
      (let* ((*standard-output*
	      (or (frame-standard-output frame) *standard-output*))
	     (*standard-input*
	      (or (frame-standard-input frame) *standard-output*))
	     (*query-io*
	      (or (frame-query-io frame) *standard-input*))
	     (*error-output*
	      (or (frame-error-output frame) *standard-output*))
	     (*pointer-documentation-output*
	      (frame-pointer-documentation-output frame))
	     (interactor
	      (not (null (find-frame-pane-of-type frame 'interactor-pane))))
	     (*command-parser*
	      (or command-parser
		  (if interactor
		      #'command-line-command-parser
		    #'menu-command-parser)))
	     (*command-unparser*
	      (or command-unparser
		  #'command-line-command-unparser))
	     (*partial-command-parser*
	      (or partial-command-parser
		  (if interactor
		      #'command-line-read-remaining-arguments-for-partial-command
		    #'menu-read-remaining-arguments-for-partial-command)))
	     (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)))))
	     #+(or aclpc acl86win32) ;; pr Aug97
	     (iterations 0))
	;; 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)
	      (when interactor
		(fresh-line *standard-input*)
		(if (stringp prompt)
		    (write-string prompt *standard-input*)
		  (funcall prompt *standard-input* frame)))
	      #+(or aclpc acl86win32) ;; pr Aug97
	      ;;--- looks like he wants to do the ugly growing far off-screen
	      ;;--- and then move the window back in.  Hacky but effective. -tjm
	      (when (= 1 (incf iterations))
		(multiple-value-bind (x y) (frame-find-position frame)
		  (when (and x y new-x new-y (> x 9900))
		    #-ignore (frame-set-position frame (max 0 (- x 10000)) (max 0 (- y 10000)))
		    #+ignore (move-sheet (frame-top-level-sheet frame) (- x 10000) (- y 10000))))
		(clean-frame frame)
		#+no (setf (sheet-enabled-p (frame-top-level-sheet frame)) nil)
		(unless (eq (frame-state frame) :enabled)
		  (enable-frame 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
;; 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
cer's avatar
cer committed
;; 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))
cer's avatar
cer committed
  (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)))))
cer's avatar
cer committed

;; 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)))
cer's avatar
cer committed
      (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)))
        (port-move-frame (port sheet) (pane-frame sheet) (max 0 left) (max 0 top))))))
cer's avatar
 
cer committed

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