Newer
Older
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; ;; $fiHeader: frames.lisp,v 1.10 92/03/10 10:12:33 cer Exp Locker: cer $
"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved.
Portions copyright (c) 1989, 1990 International Lisp Associates.
Portions copyright (c) 1991, 1992 Franz, Inc. All rights reserved."
;;--- We should add an input event-queue to frames, so that other
;;--- processes can queue up requests. This queue should be managed
;;--- like other event queues. It can contains "command" events, too.
;;--- Is it right for these to be SHEET accessors??
((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)
(calling-frame :reader frame-calling-frame :initarg :calling-frame)
;;--- How does ALL-PANES differ from PANES?
(panes :initarg :panes :accessor frame-panes)
(all-panes :initform nil)
(current-panes :initform nil :accessor frame-current-panes)
(initialized-panes :initform nil)
(pane-constructors :initarg :pane-constructors)
(top-level-sheet :accessor frame-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)
(default-size :initform nil :initarg :default-size)
(shell :accessor frame-shell)
(pointer-documentationp
:initarg :pointer-documentation
:reader frame-pointer-documentationp)
(pointer-documentation-pane :initform nil)
(properties :initform nil :initarg :properties
:accessor frame-properties))
(:default-initargs
:pointer-documentation 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)))
(defmethod frame-pointer-documentation-output ((frame standard-application-frame))
(with-slots (pointer-documentation-pane) frame
pointer-documentation-pane))
#+CLIM-1-compatibility
(define-compatibility-function (frame-top-level-window frame-top-level-sheet)
(frame)
(frame-top-level-sheet frame))
(let ((frame-manager
(etypecase parent
(null (find-frame-manager))
(list (apply #'find-frame-manager parent))
(frame-manager parent)
(application-frame (frame-manager parent))
(port (find-frame-manager :port parent))
(sheet (frame-manager (pane-frame parent))))))
(setf (slot-value frame 'frame-manager) frame-manager)
(adopt-frame frame-manager frame)))
;; Default method does nothing
(defmethod generate-panes ((framem standard-frame-manager)
(frame standard-application-frame))
(eval-when (eval compile load)
(defun define-application-frame-1 (name state-variables pane-descriptions
&key top-level layout
command-table disabled-commands)
(let* ((command-table-name (first command-table)))
;; 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
#+Genera (declare (zwei:indentation 1 25 2 3 3 1))
(with-warnings-for-definition name define-application-frame
(let (pane panes layout top-level menu-bar
command-definer command-table disabled-commands)
(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 pointer-documentation :pointer-documentation nil)
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
(extract pane :pane nil)
(extract panes :panes nil nil)
(extract layout :layout 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))
(check-type name symbol)
(check-type superclasses list)
(check-type slots list)
(check-type pane list)
(check-type panes list)
(check-type layout list)
(check-type top-level list)
(check-type disabled-commands list)
(when (and pane panes)
(error "The ~S and ~S options cannot be used together" :pane :panes))
(when (and pane layout)
(error "The ~S and ~S options cannot be used together" :pane :layout))
(when (or (and panes (null layout))
(and layout (null panes)))
(error "The ~S and ~S options must be used together" :panes :layout))
(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)
#-Silica (warn-if-layout-invalid name layout pane-descriptions)
(let ((pane-constructors
(cond (panes
(compute-pane-constructor-code panes))
(pane
(compute-pane-constructor-code `((,name ,pane)))))))
`(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
:layout ',layout
:top-level ',top-level
:command-table ',command-table))
(define-group ,name define-application-frame
(defclass ,name ,superclasses ,slots
,@options
(:default-initargs
:pointer-documentation ',pointer-documentation
:menu-bar ',menu-bar
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
,@(and command-table `(:command-table ',(car command-table)))
,@(and top-level `(:top-level ',top-level))
,@(and panes `(:pane-constructors ,pane-constructors))
,@(and layout `(:default-layout ',(caar layout)))))
,@(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
:layout ',layout
: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)
,@(compute-generate-panes-code name pane panes layout)))))))
#+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)))
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
272
273
274
275
276
277
278
279
280
281
282
#+CLIM-1-compatibility
(defmacro with-frame-state-variables
((frame-name &optional (frame '*application-frame*)) &body body)
;; frame descriptor must be findable at compile-time
(let* ((descriptor (find-frame-descriptor frame-name))
(state-variables (frame-descriptor-state-variable-names descriptor)))
`(with-slots ,state-variables ,frame ,@body)))
(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)))))))
(defun compute-generate-panes-code (name code panes layouts)
(if panes
(compute-complex-generate-panes-code name panes layouts)
(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))
,(mapcar #'(lambda (pane-spec)
(destructuring-bind (name code) pane-spec
`(,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) layout-spec
`(,name ,panes)))
layouts)))))))))))
(defun compute-pane-constructor-code (panes)
`(list ,@(mapcar #'(lambda (pane-spec)
(destructuring-bind (name code) pane-spec
`(list ',name
#'(lambda (frame framem)
(with-look-and-feel-realization (framem frame)
,code)))))
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)
(car (push (list name
(funcall (second (assoc name pane-constructors))
frame (frame-manager frame)))
all-panes))))))
(defmethod layout-frame ((frame standard-application-frame) &optional width height)
(let ((panes (frame-panes frame)))
(when panes
(unless (and width height)
(let ((sr (compose-space panes)))
(setq width (space-requirement-width sr)
height (space-requirement-height sr))))
;;--- Don't bother with this if the size didn't change?
;;-- This is wrong We want to resize the top level sheet
;;; (allocate-space panes width height)
(resize-sheet*
(or (frame-top-level-sheet frame)
panes)
width height
;;-- we need to do this because if the wm has changed the sheet
;; then this will not change its size but we need it to start
;; the layout stuff
:force t))))
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
(defmethod (setf frame-current-layout) (nv (frame standard-application-frame))
(unless (eq (frame-current-layout frame) nv)
(setf (slot-value frame 'current-layout) nv)
;; 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)
(sheet-adopt-child (frame-top-level-sheet frame) (frame-panes frame))
(multiple-value-call #'layout-frame
frame (bounding-rectangle-size (frame-top-level-sheet frame)))
(throw 'layout-changed nil)))
#+CLIM-1-compatibility
(define-compatibility-function (set-frame-layout (setf frame-current-layout))
(frame new-layout)
(setf (frame-current-layout frame) new-layout))
(defun make-application-frame (frame-name &rest options
&key frame-class
enable pretty-name
width height
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))
(with-keywords-removed (options options
'(:frame-class :pretty-name
:enable :width :height :save-under))
(let ((frame (apply #'make-instance frame-class
:name frame-name
:pretty-name (or pretty-name
(title-capitalize (string frame-name)))
:default-size (when (or width height)
(list width height))
:properties `(:save-under ,save-under)
options)))
(when enable
(enable-frame frame))
frame)))
(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)))
(defmethod enable-frame ((frame standard-application-frame))
(with-slots (default-size) frame
(ecase (frame-state frame)
(:enabled)
((:disabled :disowned)
(let ((old (frame-state frame)))
(setf (frame-state frame) :enabled)
;; 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
(if default-size
(values (first default-size) (second default-size))
(values)))
(bounding-rectangle-size
(frame-top-level-sheet frame)))))
(note-frame-enabled (frame-manager frame) frame))))))
(defmethod disable-frame ((frame standard-application-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 note-frame-enabled ((framem standard-frame-manager)
(frame standard-application-frame))
(defmethod note-frame-disabled ((framem standard-frame-manager)
(frame standard-application-frame))
)
(defmethod run-frame-top-level :around ((frame standard-application-frame))
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
(unwind-protect
(let (#-Silica (*frame-layout-changing-p* *frame-layout-changing-p*)
;; 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.
;;--- This should be done in a more modular way
;;--- If you change this, change MENU-CHOOSE-FROM-DRAWER
(*original-stream* nil)
(*input-wait-test* nil)
(*input-wait-handler* nil)
(*pointer-button-press-handler* nil)
(*numeric-argument* nil)
(*delimiter-gestures* nil)
(*activation-gestures* nil)
(*accelerator-gestures* nil)
(*input-context* nil)
(*accept-help* nil)
(*assume-all-commands-enabled* nil)
#-Silica (*sizing-application-frame* nil)
(*command-parser* 'command-line-command-parser)
(*command-unparser* 'command-line-command-unparser)
(*partial-command-parser*
'command-line-read-remaining-arguments-for-partial-command)
(*application-frame* frame))
(loop
(with-simple-restart (nil "~A top level" (frame-pretty-name frame))
(loop
(catch 'layout-changed
(let ((*application-frame* frame)
(*pointer-documentation-output*
(frame-pointer-documentation-output 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)))))))))
(disable-frame frame))))
(let ((top-level (frame-top-level frame)))
(if (atom top-level)
(funcall top-level frame)
(apply (first top-level) frame (rest top-level)))))
(defmethod default-frame-top-level ((frame standard-application-frame)
&key command-parser command-unparser
partial-command-parser
(or command-parser
(if interactor
#'command-line-command-parser
#'menu-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
(typecase *standard-input*
(output-protocol-mixin
*standard-input*)
(t
(frame-top-level-sheet frame)))))
(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*)
(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))
(invoke-restart 'frame-exit))
#-Silica
(defun display-title (frame stream)
(multiple-value-bind (pane desc) (get-frame-pane frame stream)
(when (and pane (eq pane stream))
(let ((title (getf (pane-descriptor-options desc) :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))
(when (and (eq stream pane) (not (dummy-pane-p pane)))
(multiple-value-bind (width height)
(window-inside-size stream)
(draw-string* stream (or title (frame-pretty-name frame))
(/ width 2) (/ height 2)
:align-x :center :align-y :center))
(force-output stream))
(values)))))
(defun display-command-menu (frame stream &rest keys
&key command-table &allow-other-keys)
(declare (dynamic-extent keys))
(when (or (null command-table)
(eq command-table t))
(setq command-table (frame-command-table frame)))
(with-keywords-removed (keys keys '(:command-table))
(apply #'display-command-table-menu command-table stream keys)))
;; The contract of GET-FRAME-PANE is to get a pane upon which we can do normal
;; I/O operations, that is, a CLIM stream pane
(defmethod get-frame-pane ((frame standard-application-frame) pane-name &key (errorp t))
(with-slots (all-panes) frame
(let ((pane (assoc pane-name all-panes)))
(when pane
(map-over-sheets #'(lambda (sheet)
(when (typep sheet 'clim-stream-pane)
(return-from get-frame-pane sheet)))
(second pane)))
(when errorp
(error "There is no pane named ~S in frame ~S" pane-name frame)))))
(defmethod redisplay-frame-panes (frame &key force-p)
(map-over-sheets #'(lambda (sheet)
(redisplay-frame-pane frame sheet :force-p
force-p)))
(frame-top-level-sheet frame)))
;;--- What about CLIM 0.9's PANE-NEEDS-REDISPLAY, etc?
;;--- What about CLIM 1.0's :DISPLAY-AFTER-COMMANDS :NO-CLEAR?
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
(cond ((pane-display-function pane)
(let* ((ir (slot-value pane 'incremental-redisplay-p))
(redisplay-p (if (listp ir) (first ir) ir))
(check-overlapping (or (atom ir) ;default is T
(getf (rest ir) :check-overlapping t))))
(with-simple-restart (nil "Skip redisplaying pane ~S" pane)
(loop
(with-simple-restart (nil "Retry displaying pane ~S" pane)
(return
(let ((redisplay-record
(and redisplay-p
(let ((history (stream-output-history pane)))
(when history
#+compulsive-redisplay
(when (> (output-record-count history) 1)
(cerror "Clear the output history and proceed"
"There is more than one element in this redisplay pane")
(window-clear pane))
(unless (zerop (output-record-count history))
(output-record-element history 0)))))))
(cond ((and redisplay-p
(or force-p (null redisplay-record)))
(when force-p
(window-clear pane))
(invoke-pane-redisplay-function frame pane))
(redisplay-p
(redisplay redisplay-record pane
:check-overlapping check-overlapping))
(t
(invoke-pane-display-function frame
pane))))))))))
(force-p
;;-- Is there anything else we need to do?
(stream-replay pane))))
(defun invoke-pane-redisplay-function (frame pane &rest args)
(declare (dynamic-extent args))
(updating-output (pane)
(apply #'invoke-pane-display-function frame pane args)))
(defun invoke-pane-display-function (frame pane &rest args)
(declare (dynamic-extent args))
(let* ((df (pane-display-function pane))
(display-args (if (listp df) (rest df) nil))
(display-function (if (listp df) (first df) df)))
;; Cons as little as possible...
(cond ((and (null args) (null display-args))
(funcall display-function frame pane))
((null display-args)
(apply display-function frame pane args))
((null args)
(apply display-function frame pane display-args))
(t
(apply display-function frame pane (append args display-args))))))
(defmethod read-frame-command ((frame standard-application-frame)
&key (stream *query-io*) ;frame-query-io?
;; should the rest of the *command-parser*
;; etc. variables be passed as keywords or bound?
)
(read-command (frame-command-table frame) :stream stream))
(defmethod execute-frame-command ((frame standard-application-frame) command)
(apply (command-name command) (command-arguments command)))
(defmethod command-enabled (command-name (frame standard-application-frame))
(with-slots (disabled-commands) frame
(or *assume-all-commands-enabled*
(and (not (member command-name disabled-commands))
(command-accessible-in-command-table-p
command-name (frame-command-table frame))))))
(defmethod (setf command-enabled) (enabled command-name (frame standard-application-frame))
(with-slots (disabled-commands) frame
(cond (enabled
(setf disabled-commands (delete command-name disabled-commands))
(note-command-enabled (frame-manager frame) frame command-name))
(t
(push command-name disabled-commands)
(note-command-enabled (frame-manager frame) frame command-name)))))
#+CLIM-1-compatibility
(progn
(define-compatibility-function (command-enabled-p command-enabled)
(command-name frame)
(command-enabled command-name frame))
(define-compatibility-function (enable-command (setf command-enabled))
(command-name frame)
(setf (command-enabled command-name frame) t))
(define-compatibility-function (disable-command (setf command-enabled))
(setf (command-enabled command-name frame) nil))
) ;#+CLIM-1-compatibility
(defmethod note-command-enabled ((framem standard-frame-manager)
(frame standard-application-frame) command)
(defmethod note-command-disabled ((framem standard-frame-manager)
(frame standard-application-frame) command)
(declare (ignore command)))
;;; The contract of this is to replay the contents of STREAM within the region.
(defmethod frame-replay ((frame standard-application-frame) stream &optional region)
(stream-replay stream region)
(force-output stream))
;;; The contract of this is to find an "appropriate" presentation; i.e., one
;;; satisfying the input context specified by TYPE. Everything that looks for a
;;; presentation goes through this so that applications can specialize it.
(defmethod frame-find-innermost-applicable-presentation
((frame standard-application-frame) input-context stream x y &key event)
(find-innermost-applicable-presentation
input-context stream x y
:frame frame
:modifier-state (window-modifier-state stream) :event event))
(declare (ignore stream))
(let* ((window (event-sheet button-press-event))
(x (pointer-event-x button-press-event))
(y (pointer-event-y button-press-event))
(highlighted-presentation (highlighted-presentation window nil))
(input-context *input-context*))
(when (and *click-outside-menu-handler*
(output-recording-stream-p window)
(funcall *click-outside-menu-handler*))
(when highlighted-presentation
;; Unhighlight on the way out.
;; But only unhighlight the window that the click is from.
(unhighlight-highlighted-presentation window nil))
(throw-highlighted-presentation
(or (and (output-recording-stream-p window)
(frame-find-innermost-applicable-presentation
frame input-context window x y
:event button-press-event))
*null-presentation*)
input-context
button-press-event)))
(defun find-frame-pane-of-type (frame type)
(map-over-sheets #'(lambda (sheet)
(when (typep sheet type)
(return-from find-frame-pane-of-type sheet)))
(frame-top-level-sheet frame)))
(defmethod frame-standard-output ((frame standard-application-frame))
(or (find-frame-pane-of-type frame 'application-pane)
(find-frame-pane-of-type frame 'interactor-pane)))
(defmethod frame-standard-input ((frame standard-application-frame))
(or (find-frame-pane-of-type frame 'interactor-pane)
(frame-standard-output frame)))
(defmethod frame-error-output ((frame standard-application-frame))
(frame-standard-output frame))
;;--- This causes direct-manipulation and menu-driven applications not to
;;--- maintain histories. Is there a better heuristic?
(defmethod frame-maintain-presentation-histories ((frame standard-application-frame))
(not (null (find-frame-pane-of-type frame 'interactor-pane))))
(defmethod notify-user (frame format-string &rest format-arguments)
(apply #'port-notify-user (port frame) frame format-string format-arguments))
(defvar *pointer-documentation-interval*
(max (floor (* 1/10 internal-time-units-per-second)) 1))
(defvar *last-pointer-documentation-time* 0)
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
#+Genera
(defvar *pointer-documentation-buffer*
(make-array 80 :element-type 'string-char :fill-pointer 0 :adjustable t))
;;; Produce pointer documentation
(defmethod frame-document-highlighted-presentation
((frame standard-application-frame) presentation input-context window x y stream)
(let (#+Genera (documentation-window (mouse-documentation-window window)))
;; The documentation should never say anything if we're not over a presentation
(when (null presentation)
#+Genera (if documentation-window
(scl:send documentation-window :clear-window)
(window-clear stream))
#-Genera (window-clear stream))
;; Cheap test to not do this work too often
(let ((old-modifier-state *last-pointer-documentation-modifier-state*)
(modifier-state (window-modifier-state window))
(last-time *last-pointer-documentation-time*)
(time (get-internal-real-time)))
(setq *last-pointer-documentation-modifier-state* modifier-state)
(when (and (< time (+ last-time *pointer-documentation-interval*))
(= modifier-state old-modifier-state))
(return-from frame-document-highlighted-presentation nil))
(setq *last-pointer-documentation-time* time))
(when presentation
#+Genera
(when documentation-window
(setf (fill-pointer *pointer-documentation-buffer*) 0)
(with-output-to-string (stream *pointer-documentation-buffer*)
(scl:send documentation-window :clear-window)
(when (null (frame-document-highlighted-presentation-1
frame presentation input-context window x y stream))
(setq *last-pointer-documentation-time* 0))
(scl:send documentation-window :string-out *pointer-documentation-buffer*))
(return-from frame-document-highlighted-presentation nil))
(with-output-recording-options (stream :record nil)
(with-end-of-line-action (stream :allow)
(with-end-of-page-action (stream :allow)
(window-clear stream)
(when (null (frame-document-highlighted-presentation-1
frame presentation input-context window x y stream))
(setq *last-pointer-documentation-time* 0))
(force-output stream)))))))
(defun frame-document-highlighted-presentation-1
(frame presentation input-context window x y stream)
(let ((modifier-state (window-modifier-state window)))
(declare (fixnum modifier-state))
(multiple-value-bind (left left-presentation left-context
middle middle-presentation middle-context
right right-presentation right-context)
(find-applicable-translators-for-documentation presentation input-context
frame window x y modifier-state)
(let* ((*print-length* 3)
(*print-level* 2)
(*print-circle* nil)
(*print-array* nil)
(*print-readably* nil)
(*print-pretty* nil))
(flet ((document-translator (translator presentation context-type
button-name separator)
;; Assumes 5 modifier keys and the reverse ordering of *MODIFIER-KEYS*
(let ((bit #o20)
(shift-name '("h-" "s-" "m-" "c-" "sh-")))
(declare (fixnum bit))
(dotimes (i 5)
#-(or Allegro Minima) (declare (ignore i))
(unless (zerop (logand bit modifier-state))
(write-string (car shift-name) stream))
(pop shift-name)
(setq bit (the fixnum (ash bit -1)))))
(write-string button-name stream)
(document-presentation-translator translator presentation context-type
frame nil window x y
:stream stream
:documentation-type :pointer)
(write-string separator stream)))
(declare (dynamic-extent #'document-translator))
(when left
(let ((button-name (cond ((and (eq left middle)
(eq left right))
(document-translator left left-presentation left-context
button-name (if (or middle right) "; " "."))))
(document-translator middle middle-presentation middle-context
button-name (if right "; " "."))))
(document-translator right right-presentation right-context
"R: " "."))
;; Return non-NIL if any pointer documentation was produced
(or left middle right))))))
;; This is derived directly from FIND-APPLICABLE-TRANSLATORS
(defun find-applicable-translators-for-documentation
(presentation input-context frame window x y modifier-state)
;; Assume a maximum of three pointer buttons
(let ((left nil) (left-presentation nil) (left-context nil)
(middle nil) (middle-presentation nil) (middle-context nil)
(right nil) (right-presentation nil) (right-context nil))
(macrolet ((match (translator presentation context-type button)
(let* ((symbol (symbol-name button))
(button-translator (intern symbol))
(button-presentation (fintern "~A-~A" symbol 'presentation))
(button-context (fintern "~A-~A" symbol 'context)))
`(when (and (or (null ,button-translator)
(> (presentation-translator-priority ,translator)
(presentation-translator-priority ,button-translator)))
(button-and-modifier-state-matches-gesture-name-p
(button-index ,button) modifier-state
(presentation-translator-gesture-name ,translator)))
(setq ,button-translator ,translator
,button-context ,context-type)))))
(do ((presentation presentation
(parent-presentation-with-shared-box presentation window)))
((null presentation))
(let ((from-type (presentation-type presentation)))
(dolist (context input-context)
(let ((context-type (pop context))) ;input-context-type = first
(let ((translators (find-presentation-translators
from-type context-type (frame-command-table frame))))
(when translators
(dolist (translator translators)
(when (test-presentation-translator translator
presentation context-type
frame window x y
:modifier-state modifier-state)
(match translator presentation context-type :left)
(match translator presentation context-type :middle)
(match translator presentation context-type :right)))))
(when (and (or left middle right)
*presentation-menu-translator*
(test-presentation-translator *presentation-menu-translator*
presentation context-type
frame window x y
:modifier-state modifier-state))
(match *presentation-menu-translator* presentation context-type :left)
(match *presentation-menu-translator* presentation context-type :middle)
(match *presentation-menu-translator* presentation context-type :right)))))))
(values left left-presentation left-context
middle middle-presentation middle-context
right right-presentation right-context)))
#+Genera
(defmethod mouse-documentation-window ((window window-stream)) nil)