Skip to content
Snippets Groups Projects
frames.lisp 76.9 KiB
Newer Older
cer's avatar
cer committed
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; copyright (c) 1985,1986 Franz Inc, Alameda, Ca.
;; copyright (c) 1986-1998 Franz Inc, Berkeley, CA  - All rights reserved.
;;
;; The software, data and information contained herein are proprietary
;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
;; given in confidence by Franz, Inc. pursuant to a written license
;; agreement, and may be stored and used only in accordance with the terms
;; of such license.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in
;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
;;
;; $Id: frames.lisp,v 1.96 2000/06/26 17:42:07 layer Exp $
cer's avatar
cer committed

(in-package :clim-internals)

;;;"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved.
;;; 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

(defvar *default-non-frame-stream-names*
    ;; This is a list of stream *names* which will defaultly not be
    ;; rebound to frame-specific values.  For Allegro we need to not
    ;; bind *STANDARD-ERROR* as noise output happens on that.
    ;; Actually I think it might be correct to not rebind
    ;; *STANDARD-ERROR* at all.
    '(#+allegro *error-output*
      ))

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)  
     (non-frame-stream-names :initform *default-non-frame-stream-names*
			     :initarg :non-frame-stream-names))
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))))))

(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)))

#+mswindows
(defun windows-launch-frame-helper (frame-class process-return-var &rest initargs)
  (let ((frame (apply #'make-application-frame frame-class initargs)))
    (when process-return-var
      (set process-return-var frame))

    ;; Note that this won't return until the frame exits.
    (run-frame-top-level frame)    
    frame))

;;; On mswindows, frame must be activated by the process 
;;; that created it.
#+mswindows
(defun windows-launch-frame (frame-class &rest initargs)
  (let ((namestr (string-upcase (princ-to-string frame-class)))
	(process-return-var (gensym "PRV")))
    (set process-return-var nil)
    (make-process #'(lambda () 
		      (apply #'windows-launch-frame-helper 
			     frame-class 
			     process-return-var
			     initargs))
		  :name namestr)
    
    (process-wait "windows-launch-frame" #'(lambda ()
					     (not (eql (eval process-return-var) nil))))
    
    (eval process-return-var)
    ))

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)
				  ;; On Windows, only retrieve a frame
				  ;; which has a top-level-process.
				  (when (and (typep frame frame-class)
					     #+mswindows (slot-value frame 'top-level-process))
				    (return-from find-frame frame)))
			      :frame-manager frame-manager
			      :port port)
	     nil))))

    #-mswindows
    (progn
      (when (and create (null frame))
	(with-keywords-removed (initargs initargs 
					 '(:create :activate :own-process))
	  (setq frame (apply #'make-application-frame frame-name initargs))))
      (when (and frame activate)
	(cond ((slot-value frame 'top-level-process)
	       (raise-frame frame))
	      (own-process
	       (let ((namestr (string-upcase (princ-to-string frame-class))))
		 (make-process #'(lambda () (run-frame-top-level frame))
			       :name namestr)))
	      (t
	       (run-frame-top-level frame))))
      )
    
    #+mswindows
    (progn
      (cond ((null frame)
	     (cond (create
		    (with-keywords-removed (initargs initargs 
						     '(:create :activate :own-process))
		      ;; On mswindows, frame must be activated by 
		      ;; the process that created it.		
		      (cond (activate
			     (cond (own-process
				    (setq frame 
				      (apply #'windows-launch-frame frame-class
					     initargs)))
				   (t
				    (setq frame
				      (apply #'make-application-frame frame-name initargs))
				    (run-frame-top-level frame))))				   
			    (t 
			     (setq frame
			       (apply #'make-application-frame frame-name initargs))))))
		   (t
		    nil)))
	    (activate
	     ;; Note: If we've got to this point, then 
	     ;; frame must have a top-level-process
	     ;;
	     ;; Note: This seems to work only if
	     ;; it's run in its own process.
	     (make-process #'(lambda () 
			       (raise-frame 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

cer's avatar
 
cer committed
(define-condition frame-exit (condition)
  ((frame :initarg :frame :reader frame-exit-frame)
   (options :initarg :options :initform nil :reader frame-exit-options))
cer's avatar
 
cer committed
  (:report (lambda (condition stream)
             (format stream "Exit from frame ~A" (frame-exit-frame condition)))))
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))

;; moved within file; aclwin requires primary method to come before :around
;; method -tjm
(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)
  (let ((destroy nil))
    (with-simple-restart (nil "Exit ~A" (frame-pretty-name frame))
      (handler-bind ((frame-exit
		      #'(lambda (condition)
			  (let ((exit-frame (frame-exit-frame condition))
				(options (frame-exit-options condition)))
			    (setq destroy (getf options :destroy nil))
			    (when (eq frame exit-frame)
			      (return-from run-frame-top-level nil))))))
	(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
			  (return-from run-frame-top-level (call-next-method)))))))))
	  ;; 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)
	  (when destroy (destroy-frame frame))
	  )))))
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: "))
  (unless (eq (frame-state frame) :enabled)
    (enable-frame frame))
  (loop
    (let* ((*standard-output*
	    (or (frame-standard-output frame) *standard-output*))
	   (*standard-input*
	    (or (frame-standard-input frame) *standard-input*))
	    (or (frame-query-io frame) *query-io*))
	    (or (frame-error-output frame) *error-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)))))
	   (*avv-refreshed* nil))
      ;; 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 (not *avv-refreshed*) 
	      ;;; This needs to happen after the 
	      ;;; call to redisplay-frame-panes
	      ;;; but only do it the first time.
	      (force-refresh-avv-streams frame)
	      (setq *avv-refreshed* t))
	    (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)))
		(terpri *standard-input*))
	      ;; Need this check in case the user aborted out of a command menu
	      (when command
		(execute-frame-command frame command)))))))))

(defmethod force-refresh-avv-streams (frame)
  ;;; NOTE:  Not using get-frame-pane-to-avv-stream-table.
  ;;; Don't create the hashtable if it's not already there.
  (let ((ht (frame-pane-to-avv-stream-table frame)))
    (when ht
      (maphash #'(lambda (pane pair) 
		   pane
		   (let ((avv-stream (car pair))
			 (avv-record (cdr pair)))
		     (and avv-stream
			  avv-record
			  (port avv-stream)
			  (sheet-medium avv-stream)
			  (redisplay avv-record
				     avv-stream
				     :check-overlapping t))))
	       ht))))
cer's avatar
cer committed
;; Generic because someone might want :BEFORE or :AFTER
(defmethod frame-exit ((frame standard-application-frame) 
		       &rest keys)
  (signal 'frame-exit :frame frame :options keys))
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