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.85 1997/05/31 01:00:30 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))))))
(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))))
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
(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)
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
(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))))))
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
(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: "))
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
(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))))))
(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)))
(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))
;; Moves the sheet to be near where the pointer is. It's safest to use this
;; on a top-level sheet.
(defun position-sheet-near-pointer (sheet &optional x y)
(unless (and x y)
(multiple-value-setq (x y)
(pointer-position (port-pointer (port sheet)))))
(defun display-title (frame stream &key max-width max-height)
(declare (ignore max-width max-height))
(with-slots (display-string) stream
(let ((title display-string))
(when (and (stringp title)
(not (string-equal title (frame-pretty-name frame))))
;; On some hosts this will update the title bar
(setf (frame-pretty-name frame) title))
(window-inside-size stream)
(draw-text* stream (or title (frame-pretty-name frame))
(/ width 2) (/ height 2)
:align-x :center :align-y :center)))))
(defun title-capitalize (string)
(let ((new-string (substitute #\Space #\- string)))
(when (eq new-string string)
(setq new-string (copy-seq new-string)))
(nstring-capitalize new-string)))
&key command-table max-width max-height &allow-other-keys)
(ignore max-width max-height))
(eq command-table t))
(apply #'display-command-menu-1 stream command-table keys)
(apply #'display-command-table-menu command-table stream keys))))
;; Split out to avoid consing unnecessary closure environments.
(defun display-command-menu-1 (stream command-table &rest keys)
(declare (dynamic-extent keys))
(updating-output (stream :unique-id stream
:cache-value (slot-value command-table 'menu-tick))
(apply #'display-command-table-menu command-table stream keys)))
(defmethod find-pane-named ((frame standard-application-frame) pane-name &optional (errorp t))
(with-slots (all-panes) frame
(cond ((second (assoc pane-name all-panes)))
(errorp (error "There is no pane named ~S in frame ~S" pane-name frame)))))