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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.20 - (hide annotations)
Tue Feb 26 15:45:02 2002 UTC (12 years, 1 month ago) by mikemac
Branch: MAIN
Changes since 1.19: +30 -22 lines
first cut at running the display-function
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     (prompt "Command: "))
296 mikemac 1.20 (loop
297     (let ((*standard-input* (frame-standard-input frame))
298     (*standard-output* (frame-standard-output frame))
299     (*query-io* (frame-query-io frame))
300     ;; during development, don't alter *error-output*
301     ;(*error-output* (frame-error-output frame))
302     (*command-parser* command-parser)
303     (*command-unparser* command-unparser)
304     (*partial-command-parser* partial-command-parser)
305     (prompt-style (make-text-style :fixed :italic :normal))
306     results)
307     (map-over-sheets #'(lambda (pane)
308     (if (and (typep pane 'clim-stream-pane)
309     (eq (pane-display-time pane) :command-loop)
310     (pane-display-function pane))
311     (let ((func (pane-display-function pane)))
312     (window-clear pane)
313     (funcall func frame pane))))
314     (frame-top-level-sheet frame))
315     (when *standard-input*
316     (setf (cursor-visibility (stream-text-cursor *standard-input*)) t)
317     (with-text-style (*standard-input* prompt-style)
318     (if (stringp prompt)
319     (stream-write-string *standard-input* prompt)
320     (apply prompt (list *standard-input* frame)))
321     (stream-finish-output *standard-input*))
322     (setq results (multiple-value-list (execute-frame-command frame (read-frame-command frame))))
323     (loop for result in results
324     do (print result *standard-input*))
325     (terpri *standard-input*))
326 cvs 1.10 )))
327 mikemac 1.1
328 adejneka 1.12 (defmethod read-frame-command ((frame application-frame) &key (stream *standard-input*))
329 mikemac 1.1 (read-command (frame-command-table frame) :stream stream))
330    
331     (defmethod execute-frame-command ((frame application-frame) command)
332 cvs 1.8 #+ignore (apply (command-name command) (command-arguments command))
333     (eval command))
334 mikemac 1.1
335     (defmethod make-pane-1 ((fm frame-manager) (frame application-frame) type &rest args)
336     `(make-pane-1 ,fm ,frame ',type ,@args))
337    
338     (defmethod adopt-frame ((fm frame-manager) (frame application-frame))
339     (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
340     (setf (frame-manager frame) fm)
341     (let* ((*application-frame* frame)
342 cvs 1.4 (t-l-s (make-pane-1 fm frame 'top-level-sheet-pane
343 mikemac 1.1 :name 'top-level-sheet)))
344     (setf (slot-value frame 'top-level-sheet) t-l-s)
345     (generate-panes fm frame)))
346    
347     (defmethod disown-frame ((fm frame-manager) (frame application-frame))
348     (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
349     (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
350     (setf (frame-manager frame) nil))
351    
352 cvs 1.8 (defvar *pane-realizer* nil)
353    
354 mikemac 1.1 (defmacro with-look-and-feel-realization ((frame-manager frame) &body body)
355 cvs 1.8 `(let ((*pane-realizer* ,frame-manager)
356     (*application-frame* ,frame))
357     (progn
358     ,@body)))
359 mikemac 1.1
360     (defun make-single-pane-generate-panes-form (class-name pane)
361     `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
362 moore 1.17 (with-look-and-feel-realization (fm frame)
363 mikemac 1.1 (let ((pane ,pane))
364     (setf (slot-value frame 'pane) pane)))))
365    
366     (defun make-panes-generate-panes-form (class-name panes layouts)
367     `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
368     (let ((*application-frame* frame))
369 cvs 1.8 (with-look-and-feel-realization (fm frame)
370     (let ,(loop for (name . form) in panes
371     collect `(,name (or (find-pane-named frame ',name)
372     (let ((pane
373     ,(cond
374     ((and (= (length form) 1)
375     (listp (first form)))
376     (first form))
377     ((keywordp (first form))
378     (let ((maker (intern (concatenate 'string
379     "MAKE-CLIM-"
380     (symbol-name (first form))
381     "-PANE") :clim)))
382     (if (fboundp maker)
383     `(,maker :name ',name ,@(cdr form))
384     `(make-pane ',(first form)
385     :name ',name ,@(cdr form)))))
386     (t `(make-pane ',(first form) :name ',name ,@(cdr form))))))
387 gilbert 1.19 ;; hmm?! --GB
388     (setf (slot-value pane 'name) ',name)
389     ;;
390 cvs 1.8 (push pane (slot-value frame 'panes))
391     pane))))
392     (setf (slot-value frame 'pane)
393 mikemac 1.1 (ecase (frame-current-layout frame)
394     ,@layouts)))
395     ))))
396    
397     (defmacro define-application-frame (name superclasses slots &rest options)
398     (if (null superclasses)
399     (setq superclasses '(standard-application-frame)))
400     (let ((pane nil)
401     (panes nil)
402     (layouts nil)
403     (current-layout nil)
404     (command-table nil)
405     (menu-bar t)
406     (disabled-commands nil)
407     (command-definer t)
408     (top-level '(default-frame-top-level))
409     (others nil)
410     (command-name (intern (concatenate 'string "DEFINE-" (symbol-name name) "-COMMAND"))))
411     (loop for (prop . values) in options
412     do (case prop
413     (:pane (setq pane (first values)))
414     (:panes (setq panes values))
415     (:layouts (setq layouts values))
416     (:command-table (setq command-table (first values)))
417     (:menu-bar (setq menu-bar (first values)))
418     (:disabled-commands (setq disabled-commands values))
419     (:command-definer (setq command-definer (first values)))
420     (:top-level (setq top-level (first values)))
421     (t (push (cons prop values) others))))
422     (if (or (and pane panes)
423     (and pane layouts))
424     (error ":pane cannot be specified along with either :panes or :layouts"))
425     (if pane
426     (setq panes (list 'single-pane pane)
427 moore 1.17 layouts `((:default ,(car pane)))))
428 mikemac 1.1 (setq current-layout (first (first layouts)))
429     `(progn
430     (defclass ,name ,superclasses
431     ,slots
432     (:default-initargs
433     :name ',name
434     :pretty-name ,(string-capitalize name)
435     :command-table ,command-table
436     :disabled-commands ',disabled-commands
437     :menu-bar ,menu-bar
438     :current-layout ',current-layout
439     :layouts ',layouts
440     :top-level ',top-level
441     )
442     ,@others)
443     ,(if pane
444     (make-single-pane-generate-panes-form name pane)
445     (make-panes-generate-panes-form name panes layouts))
446     ,@(if command-definer
447     `((defmacro ,command-name (name-and-options arguements &rest body)
448     (let ((name (if (listp name-and-options) (first name-and-options) name-and-options))
449     (options (if (listp name-and-options) (cdr name-and-options) nil)))
450     `(define-command ,name ,arguements ,@body))))))))
451    
452     (defun make-application-frame (frame-name
453     &rest options
454     &key pretty-name frame-manager enable state
455     left top right bottom width height save-under
456     frame-class
457     &allow-other-keys)
458 mikemac 1.16 (declare (ignore enable state left top right bottom width height save-under))
459 mikemac 1.1 (setq options (loop for (key value) on options by #'cddr
460     if (not (member key '(:pretty-name :frame-manager :enable :state
461     :left :top :right :bottom :width :height :save-under
462     :frame-class)
463 mikemac 1.15 :test #'eq))
464 mikemac 1.1 nconc (list key value)))
465     (if (null frame-class)
466     (setq frame-class frame-name))
467     (if (null pretty-name)
468     (setq pretty-name (string-capitalize frame-name)))
469     (if (null frame-manager)
470     (setq frame-manager (find-frame-manager)))
471     (let ((frame (apply #'make-instance frame-class
472     :port (frame-manager-port frame-manager)
473     :graft (find-graft :port (frame-manager-port frame-manager))
474     :name frame-name :pretty-name pretty-name options)))
475     (adopt-frame frame-manager frame)
476     frame))
477 cvs 1.4
478 cvs 1.7 ;;; Menu frame class
479    
480     (defclass menu-frame ()
481     ((left :initform 0 :initarg :left)
482     (top :initform 0 :initarg :top)
483     (top-level-sheet :initform nil :reader frame-top-level-sheet)
484     (pane :reader frame-pane :initarg :pane)
485     (graft :initform nil :accessor graft)
486     (manager :initform nil :accessor frame-manager)))
487    
488     (defmethod adopt-frame ((fm frame-manager) (frame menu-frame))
489     (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
490     (setf (slot-value frame 'manager) fm)
491     (let* ((t-l-s (make-pane-1 fm *application-frame* 'unmanaged-top-level-sheet-pane
492     :name 'top-level-sheet)))
493     (setf (slot-value frame 'top-level-sheet) t-l-s)
494     (sheet-adopt-child t-l-s (frame-pane frame))
495     (let ((graft (find-graft :port (frame-manager-port fm))))
496     (sheet-adopt-child graft t-l-s)
497     (setf (graft frame) graft))
498 hatchond 1.11 (let ((space (compose-space t-l-s)))
499 cvs 1.7 (allocate-space (frame-pane frame)
500     (space-requirement-width space)
501     (space-requirement-height space))
502     (setf (sheet-region t-l-s)
503     (make-bounding-rectangle 0 0
504     (space-requirement-width space)
505     (space-requirement-height space))))
506     (setf (sheet-transformation t-l-s)
507     (make-translation-transformation (slot-value frame 'left)
508     (slot-value frame 'top)))))
509    
510     (defmethod disown-frame ((fm frame-manager) (frame menu-frame))
511     (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
512     (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
513     (setf (frame-manager frame) nil))
514    
515     (defun make-menu-frame (pane &key (left 0) (top 0))
516     (make-instance 'menu-frame :pane pane :left left :top top))
517 moore 1.18
518     ;;; Frames and presentations
519    
520     (defmethod frame-find-innermost-applicable-presentation
521     ((frame standard-application-frame) input-context stream x y
522     &key event)
523     (find-innermost-applicable-presentation input-context stream
524     x y
525     :frame frame :event event))
526    
527     (defmethod frame-input-context-button-press-handler
528     ((frame standard-application-frame)
529     (stream output-recording-stream)
530     button-press-event)
531     (format *debug-io* "frame button press event: ~D ~D in ~S~%"
532     (pointer-event-x button-press-event)
533     (pointer-event-y button-press-event)
534     stream)
535     (let ((presentation (find-innermost-applicable-presentation
536     *input-context*
537     stream
538     (pointer-event-x button-press-event)
539     (pointer-event-y button-press-event)
540     :frame frame)))
541     (when presentation
542     (format *debug-io* "presentation: ~S of type ~S~%"
543     (presentation-object presentation)
544     (presentation-type presentation))
545     (throw-highlighted-presentation presentation
546     *input-context*
547     button-press-event))))
548    
549     (defmethod frame-input-context-button-press-handler
550     ((frame standard-application-frame) stream button-press-event)
551     (distribute-event (port stream) button-press-event))
552    
553     (defmethod frame-input-context-track-pointer
554     ((frame standard-application-frame)
555     input-context
556     (stream output-recording-stream) event)
557     (declare (ignore input-context event))
558     nil)
559    
560     (defmethod frame-input-context-track-pointer
561     ((frame standard-application-frame) input-context stream event)
562     (declare (ignore input-context))
563     (distribute-event (port stream) event))
564    
565     (defmethod frame-input-context-track-pointer :before
566     ((frame standard-application-frame) input-context stream event)
567     (if (output-recording-stream-p stream)
568     (let ((presentation (find-innermost-applicable-presentation
569     input-context
570     stream
571     (pointer-event-x event)
572     (pointer-event-y event)
573     :frame frame)))
574     (when (and (frame-hilited-presentation frame)
575     (not (eq presentation
576     (car (frame-hilited-presentation frame)))))
577     (highlight-presentation-1 (car (frame-hilited-presentation frame))
578     (cdr (frame-hilited-presentation frame))
579     :unhighlight))
580     (when presentation
581     (setf (frame-hilited-presentation frame)
582     (cons presentation stream))
583     (highlight-presentation-1 presentation
584     stream
585     :highlight)))))
586 cvs 1.7

  ViewVC Help
Powered by ViewVC 1.1.5