Newer
Older
;;; -*- 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 $
"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)
(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)
(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)
: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)
:initarg :user-specified-position-p
:reader frame-user-specified-position-p)
: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)
:accessor frame-properties)
: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))
:layouts nil
:resize-frame nil
:top-level 'default-frame-top-level))
(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))
(find-frame-manager)))
(t (find-frame-manager))))
(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)
(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)
(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)))))
;; Default method does nothing
(defmethod generate-panes ((framem standard-frame-manager)
(frame standard-application-frame))
(frame standard-application-frame))
(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
layouts))
;; 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)))
) ;eval-when
;; 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
(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)
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))
(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)
(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))
(setq superclasses '(standard-application-frame)))
(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)))
(setq command-table (list* name (rest command-table))))
(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))))
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
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
(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))))))
#+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)))
(defun warn-if-command-table-invalid (frame-name command-table)
(cond ((not (and (listp command-table)
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
(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)))))))
(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))))
(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))))))))
(framem '#:framem))
`((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)))))))))))
(defun compute-default-generate-panes-code (name panes)
(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)
(vertically ()
,@(mapcar #'(lambda (pane-spec)
(destructuring-bind (name &rest ignore) pane-spec
(declare (ignore ignore))
`(find-or-make-pane-named ,frame ',name)))
panes))))))))))
(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)))))
(defmethod layout-frame ((frame standard-application-frame) &optional width height)
(*application-frame* frame))
(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)))
;;--- Don't bother with this if the size didn't change?
;; +++rl consider making frame-resizable t the default instead
(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))))))
(defmethod (setf frame-current-layout) (layout (frame standard-application-frame))
(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
(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)
(defmethod note-frame-layout-changed ((frame-manager standard-frame-manager) (frame t))
(let ((layout-space-requirements
(cddr (assoc layout (frame-layouts frame)))))
(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))))))))))
(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
left top right bottom width height
(user-specified-position-p :unspecified)
(user-specified-size-p :unspecified)
save-under
&allow-other-keys)
(declare (dynamic-extent options))
(check-type pretty-name (or null string))
(when (null frame-class)
(setq frame-class frame-name))
:geometry :left :top :right :bottom :width :height))
`(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)))))))
(append (and left `(:left ,left))
(and top `(:top ,top))
(and width `(:width ,width))
(and height `(:height ,height)))))
(or (and (getf geometry :left)
(getf geometry :top))
#+(or aclpc acl86win32) (and left top) ;mm: ???
))
(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: ???
))
(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))
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)))
(enable-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-manager port
frame-class
&allow-other-keys)
(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))))
(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))))
(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))
(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)))
((framem standard-frame-manager) (frame standard-application-frame))
((framem standard-frame-manager) (frame standard-application-frame))
(defmethod note-frame-iconified
((framem standard-frame-manager) (frame standard-application-frame))
((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))
(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
;; 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)
`((*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)
#+(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))))
;;--- 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))))))
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
823
824
825
826
827
828
829
(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)
(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))
(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)))))
;;; 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
partial-command-parser
(prompt "Command: "))
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
(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))))))))))
;; 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))
;; Sizes an application frame based on the size of the contents of the
(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)))
(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))))))
(defmethod port-move-frame ((port basic-port) frame x y)
(move-sheet (frame-top-level-sheet frame) x y))