Newer
Older
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: frames.lisp,v 1.69 1993/06/21 20:50:04 cer Exp $
"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."
((name :initarg :name :accessor frame-name)
(pretty-name :initarg :pretty-name :accessor frame-pretty-name)
(command-table :initarg :command-table
:initform (find-command-table 'user-command-table)
:accessor frame-command-table)
(disabled-commands :initarg :disabled-commands :initform nil)
;; One of T, NIL, or a command-table; used by the menu-bar
(menu-bar :initarg :menu-bar :initform nil)
(histories :initform nil)
;; 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)
(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))
(top-level :initarg :top-level :accessor frame-top-level)
(current-layout :initarg :default-layout :initform nil
:reader frame-current-layout)
(geometry :initform nil :initarg :geometry :reader frame-geometry)
(user-specified-position-p :initform :unspecified
:initarg :user-specified-position-p
:reader frame-user-specified-position-p)
(user-specified-size-p :initform :unspecified
:initarg :user-specified-size-p
:reader frame-user-specified-size-p)
(shell :accessor frame-shell)
(pointer-documentation-p :initarg :pointer-documentation
:reader frame-pointer-documentation-p)
(properties :initform nil :initarg :properties
:accessor frame-properties)
(resizable :initarg :resize-frame
:reader frame-resizable)
(input-buffer :initform nil :initarg :input-buffer :reader frame-input-buffer)
cer
committed
(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))
(defmethod port ((frame standard-application-frame))
(port (frame-manager frame)))
(defmethod graft ((frame standard-application-frame))
(graft (frame-manager frame)))
;;--- These should really be somewhere else
(defmethod frame-manager ((stream standard-encapsulating-stream))
(cond (*application-frame* (or (frame-manager *application-frame*)
(find-frame-manager)))
&key
(frame-manager (find-frame-manager))
geometry icon)
(destructuring-bind (&key left top width height) geometry
(declare (ignore left top width height)))
(when frame-manager
(adopt-frame frame-manager frame)))
(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))))))
;; Default method does nothing
(defmethod generate-panes ((framem standard-frame-manager)
(frame standard-application-frame))
(defmethod generate-panes :after ((framem standard-frame-manager)
(frame standard-application-frame))
(adjust-layout-requirements frame (frame-current-layout frame)))
(defun define-application-frame-1 (name state-variables pane-descriptions
(declare (ignore name state-variables pane-descriptions top-level
layouts
disabled-commands))
;; If we're going to be defining commands for this application frame,
;; make sure there's an command table lying around so that all other
;; code doesn't have to be defensive against its absence.
(when command-table
(apply #'define-command-table-1 command-table)))
#+Genera (declare (zwei:indentation 1 25 2 3 3 1))
(with-warnings-for-definition name define-application-frame
command-definer command-table disabled-commands
icon geometry default-initargs)
(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)
(extract pane :pane nil)
(extract panes :panes nil nil)
(extract top-level :top-level '(default-frame-top-level))
(extract menu-bar :menu-bar t)
(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))
(check-type name symbol)
(check-type superclasses list)
(check-type slots list)
(check-type pane list)
(check-type panes list)
(check-type top-level list)
(check-type disabled-commands list)
(when (and pane panes)
(error "You must use either ~S or ~S options" :pane :panes))
(when (and panes (null layouts))
(error "You must use ~S and ~S together" :panes :layouts))
(when (null superclasses)
(setq superclasses '(standard-application-frame)))
(when (eq command-definer 't)
(setq command-definer (fintern "~A-~A-~A" 'define name 'command)))
(check-type command-definer symbol)
(cond ((null command-table))
((symbolp command-table)
(setq command-table (list command-table)))
(t (warn-if-command-table-invalid name command-table)))
(when (eq (first command-table) 't)
(setq command-table (list* name (rest command-table))))
#-Silica (warn-if-pane-descriptions-invalid name pane-descriptions)
(compute-pane-constructor-code `((,name ,pane))))))
(layout-value
`(list ,@(mapcar
#'(lambda (layout)
(destructuring-bind (name panes &rest sizes) layout
(destructuring-bind (pane &rest sizes) pane-and-size
`(list ',pane
,@sizes)))
`(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
:top-level ',top-level
:command-table ',command-table))
(define-group ,name define-application-frame
(defclass ,name ,superclasses ,slots
,@options
(:default-initargs
,@(and command-table `(:command-table ',(car command-table)))
,@(and top-level `(:top-level ',top-level))
,@(and icon `(:icon (list ,@icon)))
,@(and geometry `(:geometry (list ,@geometry)))
,@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)))
;;--- Need to handle DISABLED-COMMANDS properly,
;;--- which entails doing a COPY-LIST
(define-application-frame-1 ',name ',slots ,pane-constructors
:top-level ',top-level
:command-table ',command-table
:disabled-commands ',disabled-commands)
#+Cloe-Runtime
(cloe:define-program ,name ()
:main ,name
:debugger-hook cloe-debugger-hook)
#+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
(defmacro define-frame-command (command-table-name name-and-options arguments &body body)
(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)
,arguments
,@body)))
#+Genera
(scl::defprop define-frame-command define-command zwei:definition-function-spec-type)
#+Genera
(scl:defun (:property define-frame-command zwei:definition-function-spec-finder) (bp)
(zwei:defselect-function-spec-finder (zwei:forward-sexp bp 1 t)))
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
(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)))
(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)))))))
(let ((frame '#:frame)
(framem '#:framem))
`((defmethod generate-panes ((,framem standard-frame-manager) (,frame ,name))
(let ((*application-frame* ,frame))
(setf (frame-panes ,frame)
(frame-wrapper ,framem ,frame
(with-look-and-feel-realization (,framem ,frame)
,code)))))))))
(let ((frame '#:frame)
(framem '#:framem))
`((defmethod generate-panes ((,framem standard-frame-manager) (,frame ,name))
(destructuring-bind (name code &rest ignore) pane-spec
(declare (ignore code 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 panes &rest ignore) layout-spec
(declare (ignore ignore))
`(,name ,panes)))
layouts)))))))))))
(destructuring-bind (name code &rest options) pane-spec
(setq code (canonicalize-pane-spec name code options))
`(list ',name
#'(lambda (frame framem)
(with-look-and-feel-realization (framem frame)
,code)))))
panes)))
(unless (getf rest :name)
(setf (getf rest :name) `',name))
(apply #'find-pane-class-constructor code rest))
(t
(error "Invalid pane specification: ~S"
(list* name code rest)))))
(defmacro define-pane-type (type lambda-list &body body)
`(defmethod find-pane-class-constructor ((type (eql ',type)) ,@lambda-list)
,@body))
:text-style (parse-text-style '(:sans-serif :bold :large))
:scroll-bars nil
`(make-clim-stream-pane
:type 'command-menu-pane
,@options
:display-function `(display-command-menu :command-table ,(frame-command-table frame))
:incremental-redisplay t
:display-after-commands t
:text-style *command-table-menu-text-style*
:scroll-bars nil
:width :compute :height :compute
:end-of-page-action :allow
:end-of-line-action :allow))
(define-pane-type :interactor (&rest options &key (scroll-bars :vertical))
`(make-clim-interactor-pane
,@options
:scroll-bars ,scroll-bars))
`(make-clim-application-pane
,@options
:scroll-bars ,scroll-bars))
(define-pane-type :accept-values (&rest options &key (scroll-bars :vertical))
(declare (non-dynamic-extent options))
`(make-clim-stream-pane
:type 'pointer-documentation-pane
,@options
:display-after-commands nil
:text-style (parse-text-style '(:sans-serif :bold :normal))
:scroll-bars nil
(define-pane-type check-box (&rest options)
(declare (non-dynamic-extent options))
`(make-pane 'check-box ,@options))
(define-pane-type list-pane (&rest options)
(declare (non-dynamic-extent options))
`(make-pane 'list-pane ,@options))
(define-pane-type option-pane (&rest options)
(declare (non-dynamic-extent options))
`(make-pane 'option-pane ,@options))
(with-keywords-removed (options options '(:command-table))
`(make-pane 'menu-bar
,@options
:command-table ,(or command-table
`(frame-command-table frame)))))
(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)))
(defmethod layout-frame ((frame standard-application-frame) &optional width height)
(multiple-value-bind (graft-width graft-height)
(bounding-rectangle-size (graft frame))
(cond ((and width height)
(minf width graft-width)
(minf height graft-height))
(t
(let ((sr (compose-space panes)))
(setq width (or width (space-requirement-width sr))
height (or height (space-requirement-height sr)))
;;--- This fudge factor stuff looks dubious --SWM
(let ((fudge-factor #+Allegro 0.9 #-Allegro 1))
(minf-or width (* graft-width fudge-factor))
(minf-or height (* graft-height fudge-factor)))))))
;;--- Don't bother with this if the size didn't change?
(let ((top-sheet (or (frame-top-level-sheet frame) panes)))
(if (and (sheet-enabled-p top-sheet)
top-sheet (bounding-rectangle-size top-sheet))
(resize-sheet top-sheet width height))))))
(defmethod (setf frame-current-layout) (layout (frame standard-application-frame))
(unless (or (eq (frame-current-layout frame) layout)
(null (frame-top-level-sheet frame)))
;; First disown all the children
(dolist (name-and-pane (slot-value frame 'all-panes))
(let ((sheet (second name-and-pane)))
(when (sheet-parent sheet)
(sheet-disown-child (sheet-parent sheet) sheet))))
(dolist (child (sheet-children (frame-top-level-sheet frame)))
(sheet-disown-child (frame-top-level-sheet frame) child))
;; Now we want to give it some new ones
(generate-panes (frame-manager frame) frame)
(let ((sheets (frame-panes frame)))
(setf (sheet-enabled-p sheets) nil)
(sheet-adopt-child (frame-top-level-sheet frame) sheets)
(multiple-value-call #'layout-frame
frame (bounding-rectangle-size (frame-top-level-sheet frame)))
;;--- Don't throw, just recompute stream bindings in a principled way
(setf (sheet-enabled-p sheets) t))
(note-frame-current-layout-changed (frame-manager frame) frame)
(defmethod note-frame-current-layout-changed ((frame-manager standard-frame-manager) (frame t))
nil)
(flet ((reset-sr (sheet)
(when (panep sheet)
(change-space-requirements-to-default sheet))))
(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))))))))))
(defmethod frame-all-layouts ((frame standard-application-frame))
(mapcar #'first (frame-layouts frame)))
(defun make-application-frame (frame-name &rest options
&key frame-class
enable pretty-name
&allow-other-keys)
(declare (dynamic-extent options))
(check-type pretty-name (or null string))
(when (null frame-class)
(setq frame-class frame-name))
(error "Cannot specify ~S and ~S, S, ~S, ~S, ~S, or ~S at the same time"
:geometry :left :top :right :bottom :width :height))
(macrolet ((check-conflict (edge1 edge2 size)
`(cond
((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)))))))
(when (and (eq user-specified-position-p :unspecified)
(or (and (getf geometry :left)
(getf geometry :top))
(and left top)))
(setf user-specified-position-p t))
(when (and (eq user-specified-size-p :unspecified)
(or (and (getf geometry :width)
(getf geometry :height))
(and width height)))
(setf user-specified-size-p t)))
(let ((frame (apply #'make-instance
frame-class
:name frame-name
;;--- Perhaps this should be a default-initarg?
:pretty-name (or pretty-name
(title-capitalize (string frame-name)))
:properties `(:save-under ,save-under)
:user-specified-size-p user-specified-size-p
:user-specified-position-p user-specified-position-p
options)))
(when enable
(enable-frame frame))
frame)))
;; 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.
&key (create t) (activate t)
(own-process *multiprocessing-p*)
frame-class
&allow-other-keys)
(declare (dynamic-extent initargs))
(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))))))))
(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
(make-process #'(lambda () (run-frame-top-level frame))
:name (frame-pretty-name frame)))
(t
(run-frame-top-level frame))))
frame))
(bounding-rectangle-size
(frame-top-level-sheet frame))))
(layout-frame frame width height)
(when (and left top)
(move-sheet (frame-top-level-sheet frame) left top))
(note-frame-enabled (frame-manager frame) frame))))
(:shrunk
(note-frame-deiconified (frame-manager frame) frame)))))
(defmethod destroy-frame ((frame standard-application-frame))
(when (eq (frame-state frame) :enabled)
(disable-frame frame))
(disown-frame (frame-manager frame) frame))
((:enabled :shrunk)
(setf (frame-state frame) :disabled)
(note-frame-disabled (frame-manager frame) frame))))
(defmethod reset-frame ((frame standard-application-frame) &rest ignore)
(declare (ignore ignore))
nil)
(defmethod raise-frame ((frame standard-application-frame))
(raise-sheet (frame-top-level-sheet frame)))
(defmethod bury-frame ((frame standard-application-frame))
(bury-sheet (frame-top-level-sheet frame)))
(defmethod note-frame-enabled
((framem standard-frame-manager) (frame standard-application-frame))
)
(defmethod note-frame-disabled
((framem standard-frame-manager) (frame standard-application-frame))
)
(defmethod note-frame-iconified
((framem standard-frame-manager) (frame standard-application-frame))
(defmethod note-frame-deiconified
((framem standard-frame-manager) (frame standard-application-frame))
(defmethod port-note-frame-adopted ((port basic-port) (frame standard-application-frame))
nil)
(defmethod (setf frame-pretty-name) :before (name (frame standard-application-frame))
(check-type name string))
(defmethod (setf frame-pretty-name) :after (name (frame standard-application-frame))
(declare (ignore name))
(let ((framem (frame-manager frame)))
(when framem (frame-manager-note-pretty-name-changed framem frame))))
(defmethod frame-manager-note-pretty-name-changed ((framem standard-frame-manager)
(frame standard-application-frame))
nil)
(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)))))
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
;; Reset the state of the input editor and the presentation type system,
;; etc., in case there is an entry into another application from inside
;; the input editor, such as a Debugger written using CLIM.
(defmacro with-clim-state-reset ((&key all
(encapsulating-streams all)
(presentation-types all)
(input-editor all)
(frames all)
(command-processor all)
additional-bindings) &body body)
`(let (,@(when encapsulating-streams
`((*original-stream* nil)))
,@(when presentation-types
`((*input-wait-test* nil)
(*input-wait-handler* nil)
(*pointer-button-press-handler* nil)
(*input-context* nil)))
,@(when input-editor
`((*numeric-argument* nil)
(*delimiter-gestures* nil)
(*activation-gestures* nil)
(*accelerator-gestures* nil)
(*accelerator-numeric-argument* nil)
(*accept-help* nil)))
,@(when frames
`((*assume-all-commands-enabled* nil)
(*sizing-application-frame* nil)
(*frame-layout-changing-p* *frame-layout-changing-p*)))
,@(when command-processor
`((*command-parser* 'command-line-command-parser)
(*command-unparser* 'command-line-command-unparser)
(*partial-command-parser*
'command-line-read-remaining-arguments-for-partial-command)))
,@additional-bindings)
,@body))
;;--- It would be nice to have the CLIM 0.9 START-FRAME and STOP-FRAME functions
(defmethod run-frame-top-level :around ((frame standard-application-frame) &key)
(with-simple-restart (nil "Exit ~A" (frame-pretty-name frame))
(handler-bind ((frame-exit
#'(lambda (condition)
(let ((exit-frame (frame-exit-frame condition)))
(when (eq frame exit-frame)
(return-from run-frame-top-level nil))))))
(unwind-protect
(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))))
(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)))
;; 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)))))
;;; 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
(defmethod default-frame-top-level ((frame standard-application-frame)
&key command-parser command-unparser
cer
committed
partial-command-parser
(prompt "Command: "))
cer
committed
(or (frame-standard-output frame) *standard-output*))
cer
committed
(or (frame-standard-input frame) *standard-output*))
cer
committed
(or (frame-query-io frame) *standard-input*))
cer
committed
(or (frame-error-output frame) *standard-output*))
cer
committed
(frame-pointer-documentation-output frame))
cer
committed
(not (null (find-frame-pane-of-type frame 'interactor-pane))))
cer
committed
(or command-parser
(if interactor
#'command-line-command-parser
#'menu-command-parser)))
cer
committed
(or command-unparser
#'command-line-command-unparser))
cer
committed
(or partial-command-parser
(if interactor
#'command-line-read-remaining-arguments-for-partial-command
#'menu-read-remaining-arguments-for-partial-command)))
cer
committed
;;--- We have to ask the frame since we do not want to
;;--- just pick up a stream from the dynamic environment
(let ((si (or (frame-standard-input frame)
(frame-standard-output frame))))
(typecase si
(output-protocol-mixin si)
(t (frame-top-level-sheet frame))))))
cer
committed
(letf-globally (((frame-actual-pointer-documentation-pane frame) *pointer-documentation-output*))
(loop
;; Redisplay all the panes
(catch-abort-gestures ("Return to ~A command level" (frame-pretty-name frame))
(redisplay-frame-panes frame)
cer
committed
(fresh-line *standard-input*)
(if (stringp prompt)
(write-string prompt *standard-input*)
(funcall prompt *standard-input* frame)))
(let ((command (read-frame-command frame :stream command-stream)))
(when interactor
(terpri *standard-input*))
;; Need this check in case the user aborted out of a command menu
(when command
(execute-frame-command frame command)))))))))
;; Generic because someone might want :BEFORE or :AFTER
(defmethod frame-exit ((frame standard-application-frame))
(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))
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
;;; Sizing and moving of frames
;; Sizes an application frame based on the size of the contents of the
;; output recording stream STREAM.
(defun size-frame-from-contents (stream
&key width height
(right-margin 10) (bottom-margin 10)
(size-setter #'window-set-inside-size))
(with-slots (output-record) stream
(with-bounding-rectangle* (left top right bottom) output-record
(let* ((graft (or (graft stream)
(find-graft))) ;--- is this right?
(gw (bounding-rectangle-width (sheet-region graft)))
(gh (bounding-rectangle-height (sheet-region graft)))
;;--- Does this need to account for the size of window decorations?
(width (min gw (+ (or width (- right left)) right-margin)))
(height (min gh (+ (or height (- bottom top)) bottom-margin))))
;; The size-setter will typically resize the entire frame
(funcall size-setter stream width height)
(window-set-viewport-position stream left top)))))
;; Moves the sheet to the specified position, taking care not to move
;; it outside of the graft. It's safest to use this on a top-level sheet.
(defun position-sheet-carefully (sheet x y)
(multiple-value-bind (width height) (bounding-rectangle-size sheet)
(multiple-value-bind (graft-width graft-height)
(bounding-rectangle-size (or (graft sheet) (find-graft)))
(let* ((left x)
(top y)
(right (+ left width))
(bottom (+ top height)))
(when (> right graft-width)
(setq left (- graft-width width)))
(when (> bottom graft-height)
(setq top (- graft-height height)))