/[mcclim]/mcclim/frames.lisp
ViewVC logotype

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.25 - (hide annotations)
Mon Mar 18 19:57:50 2002 UTC (12 years, 1 month ago) by mikemac
Branch: MAIN
Changes since 1.24: +1 -1 lines
fixed a couple of typos
1 mikemac 1.1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2    
3     ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
4 cvs 1.4 ;;; (c) copyright 2000 by
5     ;;; Iban Hatchondo (hatchond@emi.u-bordeaux.fr)
6     ;;; Julien Boninfante (boninfan@emi.u-bordeaux.fr)
7     ;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
8 mikemac 1.1
9     ;;; This library is free software; you can redistribute it and/or
10     ;;; modify it under the terms of the GNU Library General Public
11     ;;; License as published by the Free Software Foundation; either
12     ;;; version 2 of the License, or (at your option) any later version.
13     ;;;
14     ;;; This library is distributed in the hope that it will be useful,
15     ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16     ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17     ;;; Library General Public License for more details.
18     ;;;
19     ;;; You should have received a copy of the GNU Library General Public
20     ;;; License along with this library; if not, write to the
21     ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22     ;;; Boston, MA 02111-1307 USA.
23    
24     (in-package :CLIM-INTERNALS)
25    
26     (defvar *application-frame* nil)
27     (defvar *default-frame-manager* nil)
28    
29 cvs 1.5 ;;; Frame-Manager class
30    
31     (defclass frame-manager ()
32     ((port :initarg :port
33     :reader frame-manager-port)
34     (frames :initform nil
35     :reader frame-manager-frames)
36     )
37     )
38    
39     (defun frame-manager-p (x)
40     (typep x 'frame-manager))
41    
42     (defun find-frame-manager (&rest options &key port &allow-other-keys)
43     (declare (special *frame-manager*))
44     (if (boundp '*frame-manager*)
45     *frame-manager*
46     (if (and *default-frame-manager*
47     (frame-manager-p *default-frame-manager*))
48     *default-frame-manager*
49     (first (frame-managers (or port (apply #'find-port options)))))))
50    
51     (defmacro with-frame-manager ((frame-manager) &body body)
52     `(let (('*frame-manager* ,frame-manager))
53     (declare (special *frame-manager*))
54     (block ,@body)))
55    
56 mikemac 1.1 ;;; Application-Frame class
57    
58     (defclass application-frame ()
59     ((port :initform nil
60     :initarg :port
61     :accessor port)
62     (graft :initform nil
63     :initarg :graft
64     :accessor graft)
65     (name :initarg :name
66     :reader frame-name)
67     (pretty-name :initarg :pretty-name
68     :accessor frame-pretty-name)
69     (command-table :initarg :command-table
70     :initform nil
71     :accessor frame-command-table)
72     (disabled-commands :initarg :disabled-commands
73     :initform nil
74     :accessor frame-disabled-commands)
75     (pane :reader frame-pane)
76     (panes :initform nil
77     :reader frame-panes)
78     (layouts :initform nil
79     :initarg :layouts
80     :reader frame-layouts)
81     (current-layout :initform nil
82     :initarg :current-layout
83     :reader frame-current-layout)
84     (top-level-sheet :initform nil
85     :reader frame-top-level-sheet)
86     (menu-bar :initarg :menu-bar
87     :initform nil)
88     (calling-frame :initarg :calling-frame
89     :initform nil)
90     (state :initarg :state
91     :initform nil
92     :accessor frame-state)
93     (manager :initform nil
94     :reader frame-manager)
95     (properties :initarg :properties
96     :initform nil)
97     (top-level :initform '(default-frame-top-level)
98     :initarg :top-level
99     :reader frame-top-level)
100 moore 1.18 (hilited-presentation :initform nil
101     :initarg :hilited-presentation
102     :accessor frame-hilited-presentation)
103 moore 1.24 ;; For context-sensitive input
104     (intercept-events :initform nil)
105     (intercept-event-queue :initform (make-instance 'standard-event-queue)
106     :initarg :intercept-event-queue
107     :accessor frame-intercept-event-queue)))
108    
109     (defmethod frame-intercept-events ((frame application-frame))
110     (without-scheduling
111     (slot-value frame 'intercept-events)))
112    
113     (defmethod (setf frame-intercept-events) (newval (frame application-frame))
114     (without-scheduling
115     (setf (slot-value frame 'intercept-events) newval)))
116    
117     ;;; XXX Should this check that the frame isn't intercepting events, so
118     ;;; it will terminate?
119     (defmethod cleanup-frame-events ((frame application-frame))
120     (loop with queue = (frame-intercept-event-queue frame)
121     for event = (event-queue-read-no-hang queue)
122     while event
123 mikemac 1.25 do nil #+ignore (dispatch-event frame event)))
124 mikemac 1.1
125     (defun application-frame-p (x)
126     (typep x 'application-frame))
127    
128     (defmethod initialize-instance :after ((frame application-frame) &rest args)
129 moore 1.24 (declare (ignore args)))
130    
131 mikemac 1.1
132 adejneka 1.13 ;;; Generic operations
133     ; (defgeneric frame-name (frame))
134     ; (defgeneric frame-pretty-name (frame))
135     ; (defgeneric (setf frame-pretty-name) (name frame))
136     ; (defgeneric frame-command-table (frame))
137     ; (defgeneric (setf frame-command-table) (command-table frame))
138     (defgeneric frame-standard-output (frame)
139     (:documentation
140     "Returns the stream that will be used for *standard-output* for the FRAME."))
141     (defgeneric frame-standard-input (frame)
142     (:documentation
143     "Returns the stream that will be used for *standard-input* for the FRAME."))
144     (defgeneric frame-query-io (frame)
145     (:documentation
146     "Returns the stream that will be used for *query-io* for the FRAME."))
147     (defgeneric frame-error-output (frame)
148     (:documentation
149     "Returns the stream that will be used for *error-output* for the FRAME."))
150     (defgeneric frame-pointer-documentation-output (frame)
151     (:documentation
152     "Returns the stream that will be used for *pointer-documentation-output*
153     for the FRAME."))
154     (defgeneric frame-calling-frame (frame)
155     (:documentation
156     "Returns the application frame that invoked the FRAME."))
157     (defgeneric frame-parent (frame)
158     (:documentation
159     "Returns the object that acts as the parent for the FRAME."))
160     ;(defgeneric frame-pane (frame) ; XXX Is it in Spec?
161     ; (:documentation
162     ; "Returns the pane that is the top-level pane in the current layout
163     ;of the FRAME's named panes."))
164     (defgeneric frame-top-level-sheet (frame)
165     (:documentation
166     "Returns the shhet that is the top-level sheet for the FRAME. This
167     is the sheet that has as its descendants all of the panes of the FRAME."))
168     (defgeneric frame-current-panes (frame)
169     (:documentation
170     "Returns a list of those named panes in the FRAME's current layout.
171     If there are no named panes, only the single, top level pane is returned."))
172     (defgeneric get-frame-pane (frame pane-name)
173     (:documentation
174     "Returns the named CLIM stream pane in the FRAME whose name is PANE-NAME."))
175     (defgeneric find-pane-named (frame pane-name)
176     (:documentation
177     "Returns the pane in the FRAME whose name is PANE-NAME."))
178     ;(defgeneric frame-current-layout (frame))
179     ;(defgeneric frame-all-layouts (frame)) ; XXX Is it in Spec?
180     (defgeneric layout-frame (frame &optional width height))
181 mikemac 1.22 (defgeneric frame-exit-frame (condition)
182     (:documentation
183     "Returns the frame that is being exited from associated with the
184     FRAME-EXIT condition."))
185 adejneka 1.13 (defgeneric frame-exit (frame) ; XXX Is it in Spec?
186     (:documentation
187     "Exits from the FRAME."))
188     (defgeneric pane-needs-redisplay (pane))
189     (defgeneric (setf pane-needs-redisplay) (value pane))
190     (defgeneric redisplay-frame-pane (frame pane &key force-p))
191     (defgeneric redisplay-frame-panes (frame &key force-p))
192     (defgeneric frame-replay (frame stream &optional region))
193     (defgeneric notify-user (frame message &key associated-window title
194     documentation exit-boxes name style text-style))
195     ;(defgeneric frame-properties (frame property))
196     ;(defgeneric (setf frame-properties) (value frame property))
197    
198    
199 mikemac 1.1 (defclass standard-application-frame (application-frame)
200     ())
201    
202     (defmethod (setf frame-manager) (fm (frame application-frame))
203     (let ((old-manager (frame-manager frame)))
204     (setf (slot-value frame 'manager) nil)
205     (when old-manager
206     (disown-frame old-manager frame)
207     (setf (slot-value frame 'panes) nil)
208     (setf (slot-value frame 'layouts) nil))
209     (setf (slot-value frame 'manager) fm)))
210    
211     (defmethod (setf frame-current-layout) (name (frame application-frame))
212     (declare (ignore name))
213     (generate-panes (frame-manager frame) frame))
214    
215     (defmethod generate-panes :before (fm (frame application-frame))
216     (declare (ignore fm))
217     (when (and (slot-boundp frame 'pane)
218     (frame-pane frame))
219     (sheet-disown-child (frame-top-level-sheet frame) (frame-pane frame))))
220    
221     (defmethod generate-panes :after (fm (frame application-frame))
222     (declare (ignore fm))
223     (sheet-adopt-child (frame-top-level-sheet frame) (frame-pane frame))
224 cvs 1.5 (sheet-adopt-child (graft frame) (frame-top-level-sheet frame))
225     (setf (sheet-transformation (frame-top-level-sheet frame))
226     (make-translation-transformation 100 100))
227 hatchond 1.11 (let ((space (compose-space (frame-top-level-sheet frame))))
228 cvs 1.5 ;; automatically generates a window-configuation-event
229     ;; which then calls allocate-space
230 mikemac 1.1 (setf (sheet-region (frame-top-level-sheet frame))
231 cvs 1.5 (make-bounding-rectangle 0 0
232     (space-requirement-width space)
233     (space-requirement-height space)))))
234 mikemac 1.1
235     (defmethod layout-frame ((frame application-frame) &optional width height)
236     (let ((pane (frame-pane frame)))
237     (if (and width (not height))
238     (error "LAYOUT-FRAME must be called with both WIDTH and HEIGHT or neither"))
239     (if (and (null width) (null height))
240 hatchond 1.11 (let ((space (compose-space pane)))
241 mikemac 1.1 (setq width (space-requirement-width space))
242     (setq height (space-requirement-height space))))
243     (allocate-space pane width height)))
244    
245 adejneka 1.13 (defun find-pane-if (predicate panes)
246     "Returns a pane satisfying PREDICATE in the forest growing from PANES"
247 cvs 1.6 (setq panes (copy-list panes))
248 cvs 1.10 (do ((pane (pop panes)(pop panes)))
249     ((null pane) nil)
250 adejneka 1.13 (if (funcall predicate pane)
251 cvs 1.10 (return pane)
252     (setq panes (nconc panes (copy-list (sheet-children pane)))))))
253 adejneka 1.13
254     (defun find-pane-of-type (panes type)
255     (find-pane-if #'(lambda (pane) (typep pane type)) panes))
256 cvs 1.6
257 adejneka 1.13 (defmethod frame-current-panes ((frame application-frame))
258     (find-pane-if #'(lambda (pane) (pane-name pane))
259     (frame-current-layout frame)))
260    
261     (defmethod get-frame-pane ((frame application-frame) pane-name)
262     (find-pane-if #'(lambda (pane)
263     (and (typep pane 'clim-stream-pane)
264     (eq pane-name
265     (pane-name pane))))
266     (frame-panes frame)))
267    
268     (defmethod find-pane-named ((frame application-frame) pane-name)
269     (find-pane-if #'(lambda (pane)
270     (eq pane-name
271     (pane-name pane)))
272     (frame-panes frame)))
273    
274 mikemac 1.1 (defmethod frame-standard-output ((frame application-frame))
275 cvs 1.6 (or (find-pane-of-type (frame-panes frame) 'application-pane)
276     (find-pane-of-type (frame-panes frame) 'interactor-pane)))
277 mikemac 1.1
278     (defmethod frame-standard-input ((frame application-frame))
279 cvs 1.6 (or (find-pane-of-type (frame-panes frame) 'interactor-pane)
280 mikemac 1.1 (frame-standard-output frame)))
281    
282     (defmethod frame-query-io ((frame application-frame))
283     (or (frame-standard-input frame)
284     (frame-standard-output frame)))
285    
286     (defmethod frame-error-output ((frame application-frame))
287     (frame-standard-output frame))
288    
289     (defvar *pointer-documentation-output* nil)
290    
291     (defmethod frame-pointer-documentation-output ((frame application-frame))
292 adejneka 1.13 (find-pane-of-type (frame-panes frame) 'pointer-documentation-pane))
293 mikemac 1.1
294     ;;; Command loop interface
295    
296 mikemac 1.22 (define-condition frame-exit (condition)
297     ((frame :initarg :frame :reader frame-exit-frame)))
298    
299     (defmethod frame-exit ((frame standard-application-frame))
300     (signal 'frame-exit :frame frame))
301    
302 mikemac 1.1 (defmethod run-frame-top-level ((frame application-frame))
303 mikemac 1.22 (handler-bind ((frame-exit #'(lambda (condition)
304     (return-from run-frame-top-level nil))))
305     (apply (first (frame-top-level frame)) frame (rest (frame-top-level frame)))))
306 mikemac 1.1
307     (defmethod run-frame-top-level :around ((frame application-frame))
308     (let ((*application-frame* frame)
309     (*input-context* nil)
310     (*input-wait-test* nil)
311     (*input-wait-handler* nil)
312     (*pointer-button-press-handler* nil))
313     (declare (special *input-context* *input-wait-test* *input-wait-handler*
314     *pointer-button-press-handler*))
315 moore 1.24 (let ((query-io (frame-query-io frame)))
316     (if query-io
317     (with-input-focus (query-io)
318     (call-next-method))
319     (call-next-method)))))
320 mikemac 1.1
321     (defmethod default-frame-top-level
322     ((frame application-frame)
323     &key (command-parser 'command-line-command-parser)
324     (command-unparser 'command-line-command-unparser)
325     (partial-command-parser
326     'command-line-read-remaining-arguments-for-partial-command)
327 mikemac 1.21 (prompt nil))
328     (sleep 4) ; wait for the panes to be finalized - KLUDGE!!! - mikemac
329 mikemac 1.20 (loop
330     (let ((*standard-input* (frame-standard-input frame))
331     (*standard-output* (frame-standard-output frame))
332     (*query-io* (frame-query-io frame))
333     ;; during development, don't alter *error-output*
334     ;(*error-output* (frame-error-output frame))
335     (*command-parser* command-parser)
336     (*command-unparser* command-unparser)
337     (*partial-command-parser* partial-command-parser)
338     (prompt-style (make-text-style :fixed :italic :normal))
339     results)
340     (map-over-sheets #'(lambda (pane)
341     (if (and (typep pane 'clim-stream-pane)
342     (eq (pane-display-time pane) :command-loop)
343     (pane-display-function pane))
344     (let ((func (pane-display-function pane)))
345     (window-clear pane)
346     (funcall func frame pane))))
347     (frame-top-level-sheet frame))
348     (when *standard-input*
349     (setf (cursor-visibility (stream-text-cursor *standard-input*)) t)
350 mikemac 1.21 (when prompt
351     (with-text-style (*standard-input* prompt-style)
352     (if (stringp prompt)
353     (stream-write-string *standard-input* prompt)
354     (apply prompt (list *standard-input* frame)))
355     (stream-finish-output *standard-input*)))
356 mikemac 1.20 (setq results (multiple-value-list (execute-frame-command frame (read-frame-command frame))))
357     (loop for result in results
358     do (print result *standard-input*))
359     (terpri *standard-input*))
360 cvs 1.10 )))
361 mikemac 1.1
362 adejneka 1.12 (defmethod read-frame-command ((frame application-frame) &key (stream *standard-input*))
363 mikemac 1.1 (read-command (frame-command-table frame) :stream stream))
364    
365     (defmethod execute-frame-command ((frame application-frame) command)
366 cvs 1.8 #+ignore (apply (command-name command) (command-arguments command))
367     (eval command))
368 mikemac 1.1
369     (defmethod make-pane-1 ((fm frame-manager) (frame application-frame) type &rest args)
370     `(make-pane-1 ,fm ,frame ',type ,@args))
371    
372     (defmethod adopt-frame ((fm frame-manager) (frame application-frame))
373     (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
374     (setf (frame-manager frame) fm)
375     (let* ((*application-frame* frame)
376 cvs 1.4 (t-l-s (make-pane-1 fm frame 'top-level-sheet-pane
377 mikemac 1.1 :name 'top-level-sheet)))
378     (setf (slot-value frame 'top-level-sheet) t-l-s)
379     (generate-panes fm frame)))
380    
381     (defmethod disown-frame ((fm frame-manager) (frame application-frame))
382     (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
383     (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
384     (setf (frame-manager frame) nil))
385    
386 cvs 1.8 (defvar *pane-realizer* nil)
387    
388 mikemac 1.1 (defmacro with-look-and-feel-realization ((frame-manager frame) &body body)
389 cvs 1.8 `(let ((*pane-realizer* ,frame-manager)
390     (*application-frame* ,frame))
391     (progn
392     ,@body)))
393 mikemac 1.1
394     (defun make-single-pane-generate-panes-form (class-name pane)
395     `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
396 moore 1.17 (with-look-and-feel-realization (fm frame)
397 mikemac 1.1 (let ((pane ,pane))
398     (setf (slot-value frame 'pane) pane)))))
399    
400     (defun make-panes-generate-panes-form (class-name panes layouts)
401     `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
402     (let ((*application-frame* frame))
403 cvs 1.8 (with-look-and-feel-realization (fm frame)
404     (let ,(loop for (name . form) in panes
405     collect `(,name (or (find-pane-named frame ',name)
406     (let ((pane
407     ,(cond
408     ((and (= (length form) 1)
409     (listp (first form)))
410     (first form))
411     ((keywordp (first form))
412     (let ((maker (intern (concatenate 'string
413     "MAKE-CLIM-"
414     (symbol-name (first form))
415     "-PANE") :clim)))
416     (if (fboundp maker)
417     `(,maker :name ',name ,@(cdr form))
418     `(make-pane ',(first form)
419     :name ',name ,@(cdr form)))))
420     (t `(make-pane ',(first form) :name ',name ,@(cdr form))))))
421 gilbert 1.19 ;; hmm?! --GB
422     (setf (slot-value pane 'name) ',name)
423     ;;
424 cvs 1.8 (push pane (slot-value frame 'panes))
425     pane))))
426     (setf (slot-value frame 'pane)
427 mikemac 1.1 (ecase (frame-current-layout frame)
428     ,@layouts)))
429     ))))
430    
431     (defmacro define-application-frame (name superclasses slots &rest options)
432     (if (null superclasses)
433     (setq superclasses '(standard-application-frame)))
434     (let ((pane nil)
435     (panes nil)
436     (layouts nil)
437     (current-layout nil)
438 mikemac 1.23 (command-table (list name))
439 mikemac 1.1 (menu-bar t)
440     (disabled-commands nil)
441     (command-definer t)
442     (top-level '(default-frame-top-level))
443     (others nil)
444     (command-name (intern (concatenate 'string "DEFINE-" (symbol-name name) "-COMMAND"))))
445     (loop for (prop . values) in options
446     do (case prop
447     (:pane (setq pane (first values)))
448     (:panes (setq panes values))
449     (:layouts (setq layouts values))
450     (:command-table (setq command-table (first values)))
451     (:menu-bar (setq menu-bar (first values)))
452     (:disabled-commands (setq disabled-commands values))
453     (:command-definer (setq command-definer (first values)))
454     (:top-level (setq top-level (first values)))
455     (t (push (cons prop values) others))))
456     (if (or (and pane panes)
457     (and pane layouts))
458     (error ":pane cannot be specified along with either :panes or :layouts"))
459     (if pane
460     (setq panes (list 'single-pane pane)
461 moore 1.17 layouts `((:default ,(car pane)))))
462 mikemac 1.1 (setq current-layout (first (first layouts)))
463     `(progn
464     (defclass ,name ,superclasses
465     ,slots
466     (:default-initargs
467     :name ',name
468     :pretty-name ,(string-capitalize name)
469 mikemac 1.23 :command-table (find-command-table ',(first command-table))
470 mikemac 1.1 :disabled-commands ',disabled-commands
471     :menu-bar ,menu-bar
472     :current-layout ',current-layout
473     :layouts ',layouts
474     :top-level ',top-level
475     )
476     ,@others)
477     ,(if pane
478     (make-single-pane-generate-panes-form name pane)
479     (make-panes-generate-panes-form name panes layouts))
480 mikemac 1.23 ,@(if command-table
481     `((define-command-table ,@command-table)))
482 mikemac 1.1 ,@(if command-definer
483     `((defmacro ,command-name (name-and-options arguements &rest body)
484     (let ((name (if (listp name-and-options) (first name-and-options) name-and-options))
485 mikemac 1.23 (options (if (listp name-and-options) (cdr name-and-options) nil))
486     (command-table ',(first command-table)))
487     `(define-command (,name :command-table ,command-table ,@options) ,arguements ,@body))))))))
488 mikemac 1.1
489     (defun make-application-frame (frame-name
490     &rest options
491     &key pretty-name frame-manager enable state
492     left top right bottom width height save-under
493     frame-class
494     &allow-other-keys)
495 mikemac 1.16 (declare (ignore enable state left top right bottom width height save-under))
496 mikemac 1.1 (setq options (loop for (key value) on options by #'cddr
497     if (not (member key '(:pretty-name :frame-manager :enable :state
498     :left :top :right :bottom :width :height :save-under
499     :frame-class)
500 mikemac 1.15 :test #'eq))
501 mikemac 1.1 nconc (list key value)))
502     (if (null frame-class)
503     (setq frame-class frame-name))
504     (if (null pretty-name)
505     (setq pretty-name (string-capitalize frame-name)))
506     (if (null frame-manager)
507     (setq frame-manager (find-frame-manager)))
508     (let ((frame (apply #'make-instance frame-class
509     :port (frame-manager-port frame-manager)
510     :graft (find-graft :port (frame-manager-port frame-manager))
511     :name frame-name :pretty-name pretty-name options)))
512     (adopt-frame frame-manager frame)
513     frame))
514 cvs 1.4
515 cvs 1.7 ;;; Menu frame class
516    
517     (defclass menu-frame ()
518     ((left :initform 0 :initarg :left)
519     (top :initform 0 :initarg :top)
520     (top-level-sheet :initform nil :reader frame-top-level-sheet)
521     (pane :reader frame-pane :initarg :pane)
522     (graft :initform nil :accessor graft)
523     (manager :initform nil :accessor frame-manager)))
524    
525     (defmethod adopt-frame ((fm frame-manager) (frame menu-frame))
526     (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
527     (setf (slot-value frame 'manager) fm)
528     (let* ((t-l-s (make-pane-1 fm *application-frame* 'unmanaged-top-level-sheet-pane
529     :name 'top-level-sheet)))
530     (setf (slot-value frame 'top-level-sheet) t-l-s)
531     (sheet-adopt-child t-l-s (frame-pane frame))
532     (let ((graft (find-graft :port (frame-manager-port fm))))
533     (sheet-adopt-child graft t-l-s)
534     (setf (graft frame) graft))
535 hatchond 1.11 (let ((space (compose-space t-l-s)))
536 cvs 1.7 (allocate-space (frame-pane frame)
537     (space-requirement-width space)
538     (space-requirement-height space))
539     (setf (sheet-region t-l-s)
540     (make-bounding-rectangle 0 0
541     (space-requirement-width space)
542     (space-requirement-height space))))
543     (setf (sheet-transformation t-l-s)
544     (make-translation-transformation (slot-value frame 'left)
545     (slot-value frame 'top)))))
546    
547     (defmethod disown-frame ((fm frame-manager) (frame menu-frame))
548     (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
549     (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
550     (setf (frame-manager frame) nil))
551    
552     (defun make-menu-frame (pane &key (left 0) (top 0))
553     (make-instance 'menu-frame :pane pane :left left :top top))
554 moore 1.18
555     ;;; Frames and presentations
556    
557     (defmethod frame-find-innermost-applicable-presentation
558     ((frame standard-application-frame) input-context stream x y
559     &key event)
560     (find-innermost-applicable-presentation input-context stream
561     x y
562     :frame frame :event event))
563    
564     (defmethod frame-input-context-button-press-handler
565     ((frame standard-application-frame)
566     (stream output-recording-stream)
567     button-press-event)
568     (format *debug-io* "frame button press event: ~D ~D in ~S~%"
569     (pointer-event-x button-press-event)
570     (pointer-event-y button-press-event)
571     stream)
572     (let ((presentation (find-innermost-applicable-presentation
573     *input-context*
574     stream
575     (pointer-event-x button-press-event)
576     (pointer-event-y button-press-event)
577     :frame frame)))
578     (when presentation
579     (format *debug-io* "presentation: ~S of type ~S~%"
580     (presentation-object presentation)
581     (presentation-type presentation))
582     (throw-highlighted-presentation presentation
583     *input-context*
584     button-press-event))))
585    
586     (defmethod frame-input-context-button-press-handler
587     ((frame standard-application-frame) stream button-press-event)
588     (distribute-event (port stream) button-press-event))
589    
590     (defmethod frame-input-context-track-pointer
591     ((frame standard-application-frame)
592     input-context
593     (stream output-recording-stream) event)
594     (declare (ignore input-context event))
595     nil)
596    
597     (defmethod frame-input-context-track-pointer
598     ((frame standard-application-frame) input-context stream event)
599     (declare (ignore input-context))
600     (distribute-event (port stream) event))
601    
602     (defmethod frame-input-context-track-pointer :before
603     ((frame standard-application-frame) input-context stream event)
604     (if (output-recording-stream-p stream)
605     (let ((presentation (find-innermost-applicable-presentation
606     input-context
607     stream
608     (pointer-event-x event)
609     (pointer-event-y event)
610     :frame frame)))
611     (when (and (frame-hilited-presentation frame)
612     (not (eq presentation
613     (car (frame-hilited-presentation frame)))))
614     (highlight-presentation-1 (car (frame-hilited-presentation frame))
615     (cdr (frame-hilited-presentation frame))
616     :unhighlight))
617     (when presentation
618     (setf (frame-hilited-presentation frame)
619     (cons presentation stream))
620     (highlight-presentation-1 presentation
621     stream
622     :highlight)))))

  ViewVC Help
Powered by ViewVC 1.1.5