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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.21 - (hide annotations)
Wed Feb 27 21:14:20 2002 UTC (12 years, 1 month ago) by mikemac
Branch: MAIN
Changes since 1.20: +8 -6 lines
turn off the prompt since ACCEPT will do that
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 mikemac 1.1 ))
104    
105     (defun application-frame-p (x)
106     (typep x 'application-frame))
107    
108     (defmethod initialize-instance :after ((frame application-frame) &rest args)
109     (declare (ignore args))
110     )
111    
112 adejneka 1.13 ;;; Generic operations
113     ; (defgeneric frame-name (frame))
114     ; (defgeneric frame-pretty-name (frame))
115     ; (defgeneric (setf frame-pretty-name) (name frame))
116     ; (defgeneric frame-command-table (frame))
117     ; (defgeneric (setf frame-command-table) (command-table frame))
118     (defgeneric frame-standard-output (frame)
119     (:documentation
120     "Returns the stream that will be used for *standard-output* for the FRAME."))
121     (defgeneric frame-standard-input (frame)
122     (:documentation
123     "Returns the stream that will be used for *standard-input* for the FRAME."))
124     (defgeneric frame-query-io (frame)
125     (:documentation
126     "Returns the stream that will be used for *query-io* for the FRAME."))
127     (defgeneric frame-error-output (frame)
128     (:documentation
129     "Returns the stream that will be used for *error-output* for the FRAME."))
130     (defgeneric frame-pointer-documentation-output (frame)
131     (:documentation
132     "Returns the stream that will be used for *pointer-documentation-output*
133     for the FRAME."))
134     (defgeneric frame-calling-frame (frame)
135     (:documentation
136     "Returns the application frame that invoked the FRAME."))
137     (defgeneric frame-parent (frame)
138     (:documentation
139     "Returns the object that acts as the parent for the FRAME."))
140     ;(defgeneric frame-pane (frame) ; XXX Is it in Spec?
141     ; (:documentation
142     ; "Returns the pane that is the top-level pane in the current layout
143     ;of the FRAME's named panes."))
144     (defgeneric frame-top-level-sheet (frame)
145     (:documentation
146     "Returns the shhet that is the top-level sheet for the FRAME. This
147     is the sheet that has as its descendants all of the panes of the FRAME."))
148     (defgeneric frame-current-panes (frame)
149     (:documentation
150     "Returns a list of those named panes in the FRAME's current layout.
151     If there are no named panes, only the single, top level pane is returned."))
152     (defgeneric get-frame-pane (frame pane-name)
153     (:documentation
154     "Returns the named CLIM stream pane in the FRAME whose name is PANE-NAME."))
155     (defgeneric find-pane-named (frame pane-name)
156     (:documentation
157     "Returns the pane in the FRAME whose name is PANE-NAME."))
158     ;(defgeneric frame-current-layout (frame))
159     ;(defgeneric frame-all-layouts (frame)) ; XXX Is it in Spec?
160     (defgeneric layout-frame (frame &optional width height))
161     ;(defgeneric frame-exit-frame (condition) ; XXX Is it in Spec?
162     ; (:documentation
163     ; "Returns the frame that is being exited from associated with the
164     ;FRAME-EXIT condition."))
165     (defgeneric frame-exit (frame) ; XXX Is it in Spec?
166     (:documentation
167     "Exits from the FRAME."))
168     (defgeneric pane-needs-redisplay (pane))
169     (defgeneric (setf pane-needs-redisplay) (value pane))
170     (defgeneric redisplay-frame-pane (frame pane &key force-p))
171     (defgeneric redisplay-frame-panes (frame &key force-p))
172     (defgeneric frame-replay (frame stream &optional region))
173     (defgeneric notify-user (frame message &key associated-window title
174     documentation exit-boxes name style text-style))
175     ;(defgeneric frame-properties (frame property))
176     ;(defgeneric (setf frame-properties) (value frame property))
177    
178    
179 mikemac 1.1 (defclass standard-application-frame (application-frame)
180     ())
181    
182     (defmethod (setf frame-manager) (fm (frame application-frame))
183     (let ((old-manager (frame-manager frame)))
184     (setf (slot-value frame 'manager) nil)
185     (when old-manager
186     (disown-frame old-manager frame)
187     (setf (slot-value frame 'panes) nil)
188     (setf (slot-value frame 'layouts) nil))
189     (setf (slot-value frame 'manager) fm)))
190    
191     (defmethod (setf frame-current-layout) (name (frame application-frame))
192     (declare (ignore name))
193     (generate-panes (frame-manager frame) frame))
194    
195     (defmethod generate-panes :before (fm (frame application-frame))
196     (declare (ignore fm))
197     (when (and (slot-boundp frame 'pane)
198     (frame-pane frame))
199     (sheet-disown-child (frame-top-level-sheet frame) (frame-pane frame))))
200    
201     (defmethod generate-panes :after (fm (frame application-frame))
202     (declare (ignore fm))
203     (sheet-adopt-child (frame-top-level-sheet frame) (frame-pane frame))
204 cvs 1.5 (sheet-adopt-child (graft frame) (frame-top-level-sheet frame))
205     (setf (sheet-transformation (frame-top-level-sheet frame))
206     (make-translation-transformation 100 100))
207 hatchond 1.11 (let ((space (compose-space (frame-top-level-sheet frame))))
208 cvs 1.5 ;; automatically generates a window-configuation-event
209     ;; which then calls allocate-space
210 mikemac 1.1 (setf (sheet-region (frame-top-level-sheet frame))
211 cvs 1.5 (make-bounding-rectangle 0 0
212     (space-requirement-width space)
213     (space-requirement-height space)))))
214 mikemac 1.1
215     (defmethod layout-frame ((frame application-frame) &optional width height)
216     (let ((pane (frame-pane frame)))
217     (if (and width (not height))
218     (error "LAYOUT-FRAME must be called with both WIDTH and HEIGHT or neither"))
219     (if (and (null width) (null height))
220 hatchond 1.11 (let ((space (compose-space pane)))
221 mikemac 1.1 (setq width (space-requirement-width space))
222     (setq height (space-requirement-height space))))
223     (allocate-space pane width height)))
224    
225 adejneka 1.13 (defun find-pane-if (predicate panes)
226     "Returns a pane satisfying PREDICATE in the forest growing from PANES"
227 cvs 1.6 (setq panes (copy-list panes))
228 cvs 1.10 (do ((pane (pop panes)(pop panes)))
229     ((null pane) nil)
230 adejneka 1.13 (if (funcall predicate pane)
231 cvs 1.10 (return pane)
232     (setq panes (nconc panes (copy-list (sheet-children pane)))))))
233 adejneka 1.13
234     (defun find-pane-of-type (panes type)
235     (find-pane-if #'(lambda (pane) (typep pane type)) panes))
236 cvs 1.6
237 adejneka 1.13 (defmethod frame-current-panes ((frame application-frame))
238     (find-pane-if #'(lambda (pane) (pane-name pane))
239     (frame-current-layout frame)))
240    
241     (defmethod get-frame-pane ((frame application-frame) pane-name)
242     (find-pane-if #'(lambda (pane)
243     (and (typep pane 'clim-stream-pane)
244     (eq pane-name
245     (pane-name pane))))
246     (frame-panes frame)))
247    
248     (defmethod find-pane-named ((frame application-frame) pane-name)
249     (find-pane-if #'(lambda (pane)
250     (eq pane-name
251     (pane-name pane)))
252     (frame-panes frame)))
253    
254 mikemac 1.1 (defmethod frame-standard-output ((frame application-frame))
255 cvs 1.6 (or (find-pane-of-type (frame-panes frame) 'application-pane)
256     (find-pane-of-type (frame-panes frame) 'interactor-pane)))
257 mikemac 1.1
258     (defmethod frame-standard-input ((frame application-frame))
259 cvs 1.6 (or (find-pane-of-type (frame-panes frame) 'interactor-pane)
260 mikemac 1.1 (frame-standard-output frame)))
261    
262     (defmethod frame-query-io ((frame application-frame))
263     (or (frame-standard-input frame)
264     (frame-standard-output frame)))
265    
266     (defmethod frame-error-output ((frame application-frame))
267     (frame-standard-output frame))
268    
269     (defvar *pointer-documentation-output* nil)
270    
271     (defmethod frame-pointer-documentation-output ((frame application-frame))
272 adejneka 1.13 (find-pane-of-type (frame-panes frame) 'pointer-documentation-pane))
273 mikemac 1.1
274     ;;; Command loop interface
275    
276     (defmethod run-frame-top-level ((frame application-frame))
277     (apply (first (frame-top-level frame)) frame (rest (frame-top-level frame))))
278    
279     (defmethod run-frame-top-level :around ((frame application-frame))
280     (let ((*application-frame* frame)
281     (*input-context* nil)
282     (*input-wait-test* nil)
283     (*input-wait-handler* nil)
284     (*pointer-button-press-handler* nil))
285     (declare (special *input-context* *input-wait-test* *input-wait-handler*
286     *pointer-button-press-handler*))
287     (call-next-method)))
288    
289     (defmethod default-frame-top-level
290     ((frame application-frame)
291     &key (command-parser 'command-line-command-parser)
292     (command-unparser 'command-line-command-unparser)
293     (partial-command-parser
294     'command-line-read-remaining-arguments-for-partial-command)
295 mikemac 1.21 (prompt nil))
296     (sleep 4) ; wait for the panes to be finalized - KLUDGE!!! - mikemac
297 mikemac 1.20 (loop
298     (let ((*standard-input* (frame-standard-input frame))
299     (*standard-output* (frame-standard-output frame))
300     (*query-io* (frame-query-io frame))
301     ;; during development, don't alter *error-output*
302     ;(*error-output* (frame-error-output frame))
303     (*command-parser* command-parser)
304     (*command-unparser* command-unparser)
305     (*partial-command-parser* partial-command-parser)
306     (prompt-style (make-text-style :fixed :italic :normal))
307     results)
308     (map-over-sheets #'(lambda (pane)
309     (if (and (typep pane 'clim-stream-pane)
310     (eq (pane-display-time pane) :command-loop)
311     (pane-display-function pane))
312     (let ((func (pane-display-function pane)))
313     (window-clear pane)
314     (funcall func frame pane))))
315     (frame-top-level-sheet frame))
316     (when *standard-input*
317     (setf (cursor-visibility (stream-text-cursor *standard-input*)) t)
318 mikemac 1.21 (when prompt
319     (with-text-style (*standard-input* prompt-style)
320     (if (stringp prompt)
321     (stream-write-string *standard-input* prompt)
322     (apply prompt (list *standard-input* frame)))
323     (stream-finish-output *standard-input*)))
324 mikemac 1.20 (setq results (multiple-value-list (execute-frame-command frame (read-frame-command frame))))
325     (loop for result in results
326     do (print result *standard-input*))
327     (terpri *standard-input*))
328 cvs 1.10 )))
329 mikemac 1.1
330 adejneka 1.12 (defmethod read-frame-command ((frame application-frame) &key (stream *standard-input*))
331 mikemac 1.1 (read-command (frame-command-table frame) :stream stream))
332    
333     (defmethod execute-frame-command ((frame application-frame) command)
334 cvs 1.8 #+ignore (apply (command-name command) (command-arguments command))
335     (eval command))
336 mikemac 1.1
337     (defmethod make-pane-1 ((fm frame-manager) (frame application-frame) type &rest args)
338     `(make-pane-1 ,fm ,frame ',type ,@args))
339    
340     (defmethod adopt-frame ((fm frame-manager) (frame application-frame))
341     (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
342     (setf (frame-manager frame) fm)
343     (let* ((*application-frame* frame)
344 cvs 1.4 (t-l-s (make-pane-1 fm frame 'top-level-sheet-pane
345 mikemac 1.1 :name 'top-level-sheet)))
346     (setf (slot-value frame 'top-level-sheet) t-l-s)
347     (generate-panes fm frame)))
348    
349     (defmethod disown-frame ((fm frame-manager) (frame application-frame))
350     (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
351     (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
352     (setf (frame-manager frame) nil))
353    
354 cvs 1.8 (defvar *pane-realizer* nil)
355    
356 mikemac 1.1 (defmacro with-look-and-feel-realization ((frame-manager frame) &body body)
357 cvs 1.8 `(let ((*pane-realizer* ,frame-manager)
358     (*application-frame* ,frame))
359     (progn
360     ,@body)))
361 mikemac 1.1
362     (defun make-single-pane-generate-panes-form (class-name pane)
363     `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
364 moore 1.17 (with-look-and-feel-realization (fm frame)
365 mikemac 1.1 (let ((pane ,pane))
366     (setf (slot-value frame 'pane) pane)))))
367    
368     (defun make-panes-generate-panes-form (class-name panes layouts)
369     `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
370     (let ((*application-frame* frame))
371 cvs 1.8 (with-look-and-feel-realization (fm frame)
372     (let ,(loop for (name . form) in panes
373     collect `(,name (or (find-pane-named frame ',name)
374     (let ((pane
375     ,(cond
376     ((and (= (length form) 1)
377     (listp (first form)))
378     (first form))
379     ((keywordp (first form))
380     (let ((maker (intern (concatenate 'string
381     "MAKE-CLIM-"
382     (symbol-name (first form))
383     "-PANE") :clim)))
384     (if (fboundp maker)
385     `(,maker :name ',name ,@(cdr form))
386     `(make-pane ',(first form)
387     :name ',name ,@(cdr form)))))
388     (t `(make-pane ',(first form) :name ',name ,@(cdr form))))))
389 gilbert 1.19 ;; hmm?! --GB
390     (setf (slot-value pane 'name) ',name)
391     ;;
392 cvs 1.8 (push pane (slot-value frame 'panes))
393     pane))))
394     (setf (slot-value frame 'pane)
395 mikemac 1.1 (ecase (frame-current-layout frame)
396     ,@layouts)))
397     ))))
398    
399     (defmacro define-application-frame (name superclasses slots &rest options)
400     (if (null superclasses)
401     (setq superclasses '(standard-application-frame)))
402     (let ((pane nil)
403     (panes nil)
404     (layouts nil)
405     (current-layout nil)
406     (command-table nil)
407     (menu-bar t)
408     (disabled-commands nil)
409     (command-definer t)
410     (top-level '(default-frame-top-level))
411     (others nil)
412     (command-name (intern (concatenate 'string "DEFINE-" (symbol-name name) "-COMMAND"))))
413     (loop for (prop . values) in options
414     do (case prop
415     (:pane (setq pane (first values)))
416     (:panes (setq panes values))
417     (:layouts (setq layouts values))
418     (:command-table (setq command-table (first values)))
419     (:menu-bar (setq menu-bar (first values)))
420     (:disabled-commands (setq disabled-commands values))
421     (:command-definer (setq command-definer (first values)))
422     (:top-level (setq top-level (first values)))
423     (t (push (cons prop values) others))))
424     (if (or (and pane panes)
425     (and pane layouts))
426     (error ":pane cannot be specified along with either :panes or :layouts"))
427     (if pane
428     (setq panes (list 'single-pane pane)
429 moore 1.17 layouts `((:default ,(car pane)))))
430 mikemac 1.1 (setq current-layout (first (first layouts)))
431     `(progn
432     (defclass ,name ,superclasses
433     ,slots
434     (:default-initargs
435     :name ',name
436     :pretty-name ,(string-capitalize name)
437     :command-table ,command-table
438     :disabled-commands ',disabled-commands
439     :menu-bar ,menu-bar
440     :current-layout ',current-layout
441     :layouts ',layouts
442     :top-level ',top-level
443     )
444     ,@others)
445     ,(if pane
446     (make-single-pane-generate-panes-form name pane)
447     (make-panes-generate-panes-form name panes layouts))
448     ,@(if command-definer
449     `((defmacro ,command-name (name-and-options arguements &rest body)
450     (let ((name (if (listp name-and-options) (first name-and-options) name-and-options))
451     (options (if (listp name-and-options) (cdr name-and-options) nil)))
452     `(define-command ,name ,arguements ,@body))))))))
453    
454     (defun make-application-frame (frame-name
455     &rest options
456     &key pretty-name frame-manager enable state
457     left top right bottom width height save-under
458     frame-class
459     &allow-other-keys)
460 mikemac 1.16 (declare (ignore enable state left top right bottom width height save-under))
461 mikemac 1.1 (setq options (loop for (key value) on options by #'cddr
462     if (not (member key '(:pretty-name :frame-manager :enable :state
463     :left :top :right :bottom :width :height :save-under
464     :frame-class)
465 mikemac 1.15 :test #'eq))
466 mikemac 1.1 nconc (list key value)))
467     (if (null frame-class)
468     (setq frame-class frame-name))
469     (if (null pretty-name)
470     (setq pretty-name (string-capitalize frame-name)))
471     (if (null frame-manager)
472     (setq frame-manager (find-frame-manager)))
473     (let ((frame (apply #'make-instance frame-class
474     :port (frame-manager-port frame-manager)
475     :graft (find-graft :port (frame-manager-port frame-manager))
476     :name frame-name :pretty-name pretty-name options)))
477     (adopt-frame frame-manager frame)
478     frame))
479 cvs 1.4
480 cvs 1.7 ;;; Menu frame class
481    
482     (defclass menu-frame ()
483     ((left :initform 0 :initarg :left)
484     (top :initform 0 :initarg :top)
485     (top-level-sheet :initform nil :reader frame-top-level-sheet)
486     (pane :reader frame-pane :initarg :pane)
487     (graft :initform nil :accessor graft)
488     (manager :initform nil :accessor frame-manager)))
489    
490     (defmethod adopt-frame ((fm frame-manager) (frame menu-frame))
491     (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
492     (setf (slot-value frame 'manager) fm)
493     (let* ((t-l-s (make-pane-1 fm *application-frame* 'unmanaged-top-level-sheet-pane
494     :name 'top-level-sheet)))
495     (setf (slot-value frame 'top-level-sheet) t-l-s)
496     (sheet-adopt-child t-l-s (frame-pane frame))
497     (let ((graft (find-graft :port (frame-manager-port fm))))
498     (sheet-adopt-child graft t-l-s)
499     (setf (graft frame) graft))
500 hatchond 1.11 (let ((space (compose-space t-l-s)))
501 cvs 1.7 (allocate-space (frame-pane frame)
502     (space-requirement-width space)
503     (space-requirement-height space))
504     (setf (sheet-region t-l-s)
505     (make-bounding-rectangle 0 0
506     (space-requirement-width space)
507     (space-requirement-height space))))
508     (setf (sheet-transformation t-l-s)
509     (make-translation-transformation (slot-value frame 'left)
510     (slot-value frame 'top)))))
511    
512     (defmethod disown-frame ((fm frame-manager) (frame menu-frame))
513     (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
514     (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
515     (setf (frame-manager frame) nil))
516    
517     (defun make-menu-frame (pane &key (left 0) (top 0))
518     (make-instance 'menu-frame :pane pane :left left :top top))
519 moore 1.18
520     ;;; Frames and presentations
521    
522     (defmethod frame-find-innermost-applicable-presentation
523     ((frame standard-application-frame) input-context stream x y
524     &key event)
525     (find-innermost-applicable-presentation input-context stream
526     x y
527     :frame frame :event event))
528    
529     (defmethod frame-input-context-button-press-handler
530     ((frame standard-application-frame)
531     (stream output-recording-stream)
532     button-press-event)
533     (format *debug-io* "frame button press event: ~D ~D in ~S~%"
534     (pointer-event-x button-press-event)
535     (pointer-event-y button-press-event)
536     stream)
537     (let ((presentation (find-innermost-applicable-presentation
538     *input-context*
539     stream
540     (pointer-event-x button-press-event)
541     (pointer-event-y button-press-event)
542     :frame frame)))
543     (when presentation
544     (format *debug-io* "presentation: ~S of type ~S~%"
545     (presentation-object presentation)
546     (presentation-type presentation))
547     (throw-highlighted-presentation presentation
548     *input-context*
549     button-press-event))))
550    
551     (defmethod frame-input-context-button-press-handler
552     ((frame standard-application-frame) stream button-press-event)
553     (distribute-event (port stream) button-press-event))
554    
555     (defmethod frame-input-context-track-pointer
556     ((frame standard-application-frame)
557     input-context
558     (stream output-recording-stream) event)
559     (declare (ignore input-context event))
560     nil)
561    
562     (defmethod frame-input-context-track-pointer
563     ((frame standard-application-frame) input-context stream event)
564     (declare (ignore input-context))
565     (distribute-event (port stream) event))
566    
567     (defmethod frame-input-context-track-pointer :before
568     ((frame standard-application-frame) input-context stream event)
569     (if (output-recording-stream-p stream)
570     (let ((presentation (find-innermost-applicable-presentation
571     input-context
572     stream
573     (pointer-event-x event)
574     (pointer-event-y event)
575     :frame frame)))
576     (when (and (frame-hilited-presentation frame)
577     (not (eq presentation
578     (car (frame-hilited-presentation frame)))))
579     (highlight-presentation-1 (car (frame-hilited-presentation frame))
580     (cdr (frame-hilited-presentation frame))
581     :unhighlight))
582     (when presentation
583     (setf (frame-hilited-presentation frame)
584     (cons presentation stream))
585     (highlight-presentation-1 presentation
586     stream
587     :highlight)))))
588 cvs 1.7

  ViewVC Help
Powered by ViewVC 1.1.5