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

Contents of /mcclim/presentations.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.86 - (hide annotations)
Wed Dec 16 13:15:38 2009 UTC (4 years, 4 months ago) by rstrandh
Branch: MAIN
CVS Tags: HEAD
Changes since 1.85: +1 -1 lines
Fixed a typo.

Thanks to Stas Boukarev.
1 mikemac 1.1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2    
3     ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
4 moore 1.10 ;;; (c) copyright 2001,2002 by Tim Moore (moore@bricoworks.com)
5 mikemac 1.1 ;;; This library is free software; you can redistribute it and/or
6     ;;; modify it under the terms of the GNU Library General Public
7     ;;; License as published by the Free Software Foundation; either
8     ;;; version 2 of the License, or (at your option) any later version.
9     ;;;
10     ;;; This library is distributed in the hope that it will be useful,
11     ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12     ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13     ;;; Library General Public License for more details.
14     ;;;
15     ;;; You should have received a copy of the GNU Library General Public
16 adejneka 1.36 ;;; License along with this library; if not, write to the
17     ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
18 mikemac 1.1 ;;; Boston, MA 02111-1307 USA.
19    
20 moore 1.48 ;;; Implementation of the presentation type system, presentation generic
21     ;;; functions and methods, presentation translators, finding an applicable
22     ;;;presentation.
23    
24 mikemac 1.49 (in-package :clim-internals)
25 mikemac 1.1
26     ;;; PRESENTATION class
27    
28 moore 1.6 (defvar *allow-sensitive-inferiors* t)
29    
30     (defclass presentation-mixin (presentation)
31     ((object :accessor presentation-object :initarg :object)
32     (type :accessor presentation-type :initarg :type)
33     (view :accessor presentation-view :initarg :view)
34     (single-box :accessor presentation-single-box :initarg :single-box
35     :initform nil)
36     (modifier :reader presentation-modifier :initarg :modifier :initform nil)
37     (is-sensitive :reader is-sensitive :initarg :is-sensitive
38     :initform *allow-sensitive-inferiors*)))
39    
40    
41 adejneka 1.36 (defclass standard-presentation
42 moore 1.20 (presentation-mixin standard-sequence-output-record)
43 moore 1.6 ())
44    
45 tmoore 1.70 (defvar *print-presentation-verbose* nil)
46    
47     (defmethod print-object ((self standard-presentation) stream)
48     (print-unreadable-object (self stream :type t :identity t)
49     (with-bounding-rectangle* (x1 y1 x2 y2)
50     self
51     (format stream "~D:~D,~D:~D ~S" x1 x2 y1 y2 (presentation-type self))
52     (when *print-presentation-verbose*
53     (format stream " ~S" (presentation-object self))))))
54    
55 thenriksen 1.84 (defmacro with-output-as-presentation ((stream object type
56     &rest key-args
57     &key modifier single-box
58     (allow-sensitive-inferiors t)
59     parent
60     (record-type
61     ''standard-presentation)
62     &allow-other-keys)
63     &body body)
64     (declare (ignore parent single-box modifier))
65     (setq stream (stream-designator-symbol stream '*standard-output*))
66     (multiple-value-bind (decls with-body)
67     (get-body-declarations body)
68     (with-gensyms (record-arg continuation)
69     (with-keywords-removed (key-args (:record-type
70     :allow-sensitive-inferiors))
71     `(flet ((,continuation ()
72     ,@decls
73     ,@with-body))
74 rstrandh 1.86 (declare (dynamic-extent #',continuation))
75 thenriksen 1.84 (if (and (output-recording-stream-p ,stream)
76     *allow-sensitive-inferiors*)
77     (with-new-output-record
78     (,stream ,record-type ,record-arg
79     :object ,object
80     :type (expand-presentation-type-abbreviation
81     ,type)
82     ,@key-args)
83     (let ((*allow-sensitive-inferiors*
84     ,allow-sensitive-inferiors))
85     (,continuation)))
86     (,continuation)))))))
87    
88 moore 1.3 (defgeneric ptype-specializer (type)
89     (:documentation "The specializer to use for this type in a presentation
90     method lambda list"))
91    
92 adejneka 1.36 ;;; Metaclass for presentation types. For presentation types not associated
93 moore 1.3 ;;; with CLOS classes, objects with this metaclass are used as a proxy for the
94 moore 1.59 ;;; type during presentation method dispatch. We don't prevent these
95     ;;; presentation proxies from being subclasses of standard-object,
96     ;;; but in presentation method dispatch we remove methods on standard
97     ;;; object for presentation types that are not CLOS classes. The
98     ;;; presentation type metaclass for T is the builtin object T instead
99     ;;; of a presentation-type-class; in this way we can avoid weirdness
100     ;;; with T being a subtype of standard-object!
101     ;;;
102 moore 1.34
103 moore 1.59 (defclass presentation-type ()
104     ((type-name :accessor type-name :initarg :type-name
105     :documentation "The name assigned to the presentation
106 moore 1.3 type, as opposed to the name constructed for the class")
107 moore 1.59 (ptype-specializer :accessor ptype-specializer :initarg :ptype-specializer)
108     (parameters :accessor parameters :initarg :parameters :initform nil)
109     (parameters-lambda-list :accessor parameters-lambda-list
110     :initarg :parameters-lambda-list
111     :initform nil
112     :documentation "The parameters lambda list, altered for use in destructuring bind")
113     (options :accessor options :initarg :options :initform nil)
114     (options-lambda-list :accessor options-lambda-list
115     :initarg :options-lambda-list
116     :initform nil
117     :documentation "The options lambda list,
118 moore 1.3 altered for use in destructuring bind")
119 moore 1.59 (inherit-from :accessor inherit-from
120     :initarg :inherit-from
121     :documentation "Inherit-from form with dummys substituted")
122     (inherit-from-function :accessor inherit-from-function
123     :initarg :inherit-from-function
124     :documentation "Function that returns the inherit-from form")
125     (description :accessor description :initarg :description)
126     (history :accessor history :initarg :history :initform nil
127     :documentation "Who knows?")
128     (parameters-are-types :accessor parameters-are-types
129     :initarg :parameters-are-types
130     :initform nil)
131     (expansion-function :accessor expansion-function
132     :initarg :expansion-function
133     :documentation "A function which expands the typespec
134 moore 1.4 fully, including defaulting parameters and options.")))
135 moore 1.3
136 moore 1.59 (defmethod initialize-instance :after ((obj presentation-type) &key)
137     (unless (slot-boundp obj 'ptype-specializer)
138     (setf (slot-value obj 'ptype-specializer)
139     (make-presentation-type-name (slot-value obj 'type-name)))))
140    
141     (defclass presentation-type-class (presentation-type standard-class)
142     ())
143    
144     (defmethod clim-mop:validate-superclass ((class presentation-type-class)
145     (super standard-class))
146     t)
147    
148     (defclass clos-presentation-type (presentation-type)
149     ((clos-class :accessor clos-class :initarg :clos-class
150     :documentation "Holds the class object of the CLOS class of this presentation type")))
151    
152     (defmethod initialize-instance :after ((obj clos-presentation-type)
153     &key (ptype-specializer
154     nil
155     ptype-specializer-p))
156     (declare (ignore ptype-specializer))
157     (unless ptype-specializer-p
158     (setf (slot-value obj 'ptype-specializer)
159     (slot-value obj 'type-name))))
160 moore 1.14
161 moore 1.59 (defmethod history ((ptype standard-class))
162     "Default for CLOS types that are not defined explicitly as
163 moore 1.58 presentation types."
164 moore 1.59 t)
165    
166     (defvar *builtin-t-class* (find-class t))
167    
168     ;;;Methods for the T presentation type
169     (defmethod type-name ((class (eql *builtin-t-class*)))
170     t)
171    
172     (defmethod ptype-specializer ((class (eql *builtin-t-class*)))
173     t)
174    
175     (defmethod parameters ((class (eql *builtin-t-class*)))
176     nil)
177    
178     (defmethod parameters-lambda-list ((class (eql *builtin-t-class*)))
179     nil)
180    
181     (defmethod options ((class (eql *builtin-t-class*)))
182     nil)
183    
184     (defmethod options-lambda-list ((class (eql *builtin-t-class*)))
185     nil)
186    
187     (defmethod inherit-from ((class (eql *builtin-t-class*)))
188     nil)
189    
190     (defmethod inherit-from-function ((class (eql *builtin-t-class*)))
191     #'(lambda (type)
192     (declare (ignore type))
193     nil))
194    
195     (defmethod description ((class (eql *builtin-t-class*)))
196     "The supertype of all presentation types.")
197    
198     (defmethod history ((class (eql *builtin-t-class*)))
199     t)
200    
201     (defmethod parameters-are-types ((class (eql *builtin-t-class*)))
202     nil)
203    
204     (defmethod expansion-function ((class (eql *builtin-t-class*)))
205     #'(lambda (type)
206     (declare (ignore type))
207     t))
208    
209     (defun make-presentation-type-name (name)
210     (intern (format nil "(presentation-type ~A::~A)"
211     (package-name (symbol-package name))
212     (symbol-name name))
213     :clim-internals))
214 moore 1.3
215 moore 1.59 (defun transform-parameters-lambda-list (ll)
216     "Change the destructuring lambda list so that any optional or key variable
217 moore 1.3 that has no default is supplied with '*"
218 moore 1.59 (when (atom ll)
219     (return-from transform-parameters-lambda-list ll))
220     (let ((state 'required))
221     (loop for lambda-var in ll
222     collect
223     (cond ((member lambda-var lambda-list-keywords :test #'eq)
224     (setq state lambda-var)
225     lambda-var)
226     ((eq state '&optional)
227     (if (atom lambda-var)
228     `(,lambda-var '*)
229     (cons (transform-parameters-lambda-list (car lambda-var))
230     (or (cdr lambda-var) '('*)))))
231     ((eq state '&key)
232     (cond ((atom lambda-var)
233     `(,lambda-var '*))
234     ((atom (car lambda-var))
235     (cons (car lambda-var)
236     (or (cdr lambda-var) '('*))))
237     (t (destructuring-bind
238     ((var pattern)
239     &optional (default nil default-p)
240     &rest supplied-tail)
241     lambda-var
242     `((,var ,(transform-parameters-lambda-list
243     pattern))
244     ,(if default-p
245     default
246     '*)
247     ,@supplied-tail)))))
248     ((member state '(required &rest &body &whole))
249     (when (eq state '&whole)
250     (setq state 'required))
251     (transform-parameters-lambda-list lambda-var))
252     (t lambda-var)))))
253    
254     (defun fake-params-args (ll)
255     (let ((state 'required))
256     (flet ((do-arg (lambda-var)
257     (let ((var-name (symbol-name lambda-var)))
258     (cond ((or (eq state 'required) (eq state '&optional))
259     (list (gensym var-name)))
260     ((eq state '&key)
261     `(,(intern var-name :keyword) ,(gensym var-name)))
262     (t nil)))))
263 moore 1.14 (loop for lambda-var in ll
264 moore 1.59 append (cond ((member lambda-var lambda-list-keywords :test #'eq)
265     (setq state lambda-var)
266     nil)
267     ((eq state '&whole)
268     (setq state 'required)
269     nil)
270     ((atom lambda-var)
271     (do-arg lambda-var))
272     ((consp lambda-var)
273     (let ((var (car lambda-var)))
274     (do-arg (if (and (eq state '&key) (consp var))
275     (car var)
276 thenriksen 1.81 var)))))))))
277 moore 1.3
278     ;;; Yet another variation on a theme...
279    
280 moore 1.59 (defun get-all-params (ll)
281     (unless ll
282     (return-from get-all-params nil))
283     (when (atom ll)
284     (return-from get-all-params (list ll)))
285     (let ((state 'required))
286     (loop for arg in ll
287     append (cond ((member arg lambda-list-keywords :test #'eq)
288     (setq state arg)
289     nil)
290     ((eq state 'required)
291     (get-all-params arg))
292     ((or (eq state '&optional) (eq state '&aux))
293     (if (atom arg)
294     (list arg)
295     (get-all-params (car arg))))
296     ((eq state '&key)
297     (cond ((atom arg)
298     (list arg))
299     ((atom (car arg))
300     (list (car arg)))
301     (t (get-all-params (cadar arg)))))
302     ((member state '(required &rest &body &whole))
303     (when (eq state '&whole)
304     (setq state 'required))
305     (get-all-params arg))
306     (t nil)))))
307 moore 1.3
308 moore 1.4 ;;; ...And another. Given a lambda list, return a form that replicates the
309     ;;; structure of the argument with variables filled in.
310    
311 moore 1.59 (defun map-over-lambda-list (function ll
312     &key (pass-lambda-list-keywords nil))
313     (declare (ignore function pass-lambda-list-keywords))
314     (unless ll
315     (return-from map-over-lambda-list nil))
316     (when (atom ll)
317     (return-from map-over-lambda-list ll))
318     (loop for args-tail = ll then (cdr args-tail)))
319    
320     (defun make-keyword (sym)
321     (intern (symbol-name sym) :keyword))
322    
323     (defun cull-keywords (keys prop-list)
324     (let ((plist (copy-list prop-list)))
325     (loop for key in keys
326     do (remf plist key))
327     plist))
328 moore 1.4
329 moore 1.59 (defun recreate-lambda-list (ll)
330     "Helper function. Returns a form that, when evaluated inside a
331 moore 1.4 DESTRUCTURING-BIND using ll, recreates the argument list with all defaults
332     filled in."
333 moore 1.59 (unless ll
334     (return-from recreate-lambda-list nil))
335     (when (atom ll)
336     (return-from recreate-lambda-list ll))
337     (let ((state 'required)
338     (rest-var nil)
339     (has-keys nil)
340     (keys nil)
341     (allow-other-keys nil))
342     (loop for arg in ll
343     append (cond ((member arg lambda-list-keywords :test #'eq)
344     (setq state arg)
345     (when (eq arg '&key)
346     (setq has-keys t))
347     (when (eq arg '&allow-other-keys)
348     (setq allow-other-keys t))
349     nil)
350     ((eq state '&whole)
351     nil)
352     ((eq state 'required)
353     (list (recreate-lambda-list arg)))
354     ((eq state '&optional)
355     (if (atom arg)
356     (list arg)
357     (list (recreate-lambda-list (car arg)))))
358     ((or (eq state '&rest) (eq state '&body))
359     (setq rest-var arg)
360     nil)
361     ((eq state '&key)
362     (let ((key nil)
363     (var nil))
364     (cond ((atom arg)
365     (setq key (make-keyword arg)
366     var arg))
367     ((atom (car arg))
368     (setq key (make-keyword (car arg))
369     var (car arg)))
370 moore 1.4
371 moore 1.59 (t (destructuring-bind
372     ((keyword pattern) &rest tail)
373     arg
374     (declare (ignore tail))
375     (setq key keyword
376     var (recreate-lambda-list
377     pattern)))))
378     (push key keys)
379     (list key var)))
380     (t nil))
381     into result-form
382     finally (cond ((or (not rest-var)
383     (and has-keys
384     (not allow-other-keys)))
385     (return `(list ,@result-form)))
386     ((not has-keys)
387     (return `(list* ,@result-form ,rest-var)))
388     (t (return `(list* ,@result-form
389     (cull-keywords ',(nreverse keys)
390     ,rest-var))))))))
391    
392     (defun transform-options-lambda-list (ll)
393     "Return a legal lambda list given an options specification"
394     (let ((descriptionp nil))
395     (loop for spec in ll
396     collect (if (atom spec)
397     (progn
398     (when (eq (make-keyword spec) :description)
399     (setq descriptionp t))
400     spec)
401     (progn
402     (let ((key (if (atom (car spec))
403     (make-keyword (car spec))
404     (caar spec))))
405     (when (eq key :description)
406     (setq descriptionp t)))
407     (ldiff spec (cdddr spec))))
408     into specs
409     finally (return `(&key
410     ,@specs
411     ,@(unless descriptionp
412     `(((:description ,(gensym))))))))))
413 moore 1.5
414 moore 1.3
415     ;;; External function
416 moore 1.64 (declaim (inline presentation-type-name))
417    
418 moore 1.59 (defun presentation-type-name (type)
419     (cond ((atom type)
420     type)
421     ((atom (car type))
422     (car type))
423     (t (caar type))))
424    
425     (defun decode-parameters (type)
426     (cond ((atom type)
427     nil)
428     ((atom (car type))
429     (cdr type))
430     (t (cdar type))))
431    
432     (defun decode-options (type)
433     (if (or (atom type) (atom (car type)))
434     nil
435     (cdr type)))
436    
437     (defun make-inherit-from-lambda (params-ll options-ll form)
438     (let ((type (gensym "TYPE")))
439     `(lambda (,type)
440     (destructuring-bind ,params-ll (decode-parameters ,type)
441     (declare (ignorable ,@(get-all-params params-ll)))
442     (destructuring-bind ,options-ll (decode-options ,type)
443     (declare (ignorable ,@(get-all-params options-ll)))
444     ,form)))))
445    
446 moore 1.3
447 moore 1.22 (eval-when (:compile-toplevel :load-toplevel :execute)
448 moore 1.3 (defmacro with-presentation-type-decoded ((name
449     &optional (params nil params-p)
450     (options nil options-p))
451     type &body body)
452     (let ((type-var (gensym "TYPE-VAR")))
453     `(let* ((,type-var ,type)
454     (,name (presentation-type-name ,type-var))
455     ,@(and params-p `((,params (decode-parameters ,type-var))))
456     ,@(and options-p `((,options (decode-options ,type-var)))))
457     ,@body)))
458 moore 1.22 )
459 moore 1.3
460 moore 1.14 (eval-when (:compile-toplevel :load-toplevel :execute)
461     (defun make-expansion-lambda (params-ll options-ll)
462     (let ((params-form (recreate-lambda-list params-ll))
463     (options-form (recreate-lambda-list options-ll))
464     (parameters (gensym))
465     (options (gensym)))
466     `(lambda (typespec)
467     (with-presentation-type-decoded (name ,parameters ,options)
468     typespec
469     (make-type-spec name
470     (destructuring-bind ,params-ll
471     ,parameters
472     ,params-form)
473     (destructuring-bind ,options-ll
474     ,options
475     ,options-form)))))))
476    
477 moore 1.59 (defvar *presentation-type-table* (make-hash-table :test #'eq))
478    
479     (setf (gethash t *presentation-type-table*) (find-class t))
480 moore 1.3
481     (defgeneric get-ptype-metaclass (type))
482    
483     (defmethod get-ptype-metaclass ((type symbol))
484     (let ((maybe-meta (gethash type *presentation-type-table*)))
485     (if maybe-meta
486     (get-ptype-metaclass maybe-meta)
487 moore 1.34 (let ((system-meta (find-class type nil)))
488     (and (typep system-meta 'standard-class)
489     system-meta)))))
490 moore 1.3
491     (defmethod get-ptype-metaclass ((type presentation-type-class))
492     type)
493    
494     (defmethod get-ptype-metaclass ((type clos-presentation-type))
495     (clos-class type))
496    
497 moore 1.59 (defmethod get-ptype-metaclass ((type (eql *builtin-t-class*)))
498     type)
499    
500 thenriksen 1.78 (defmethod get-ptype-metaclass ((type class))
501     type)
502    
503     (defmethod get-ptype-metaclass (type)
504     (error "~A is not the name of a presentation type" type))
505    
506 moore 1.66 ;;; external functions
507     (defun find-presentation-type-class (name &optional (errorp t) environment)
508     (declare (ignore environment))
509     (let ((metaclass (get-ptype-metaclass name)))
510     (cond (metaclass
511     metaclass)
512     (errorp
513     (error "~S is not the name of a presentation type" name))
514     (t nil))))
515    
516     (defun class-presentation-type-name (class &optional environment)
517     (declare (ignore environment))
518     (cond ((typep class 'presentation-type)
519     (type-name class))
520     (t (class-name class))))
521    
522 moore 1.59 ;;; For the presentation class T, the stand in object must not be a
523     ;;; standard-object. So... why not the symbol T?
524    
525     (defvar *class-t-prototype* t)
526    
527 moore 1.15 (defun prototype-or-error (name)
528     (let ((ptype-meta (get-ptype-metaclass name)))
529     (unless ptype-meta
530     (error "~S is an unknown presentation type" name))
531 moore 1.59 (when (eq ptype-meta *builtin-t-class*)
532     (return-from prototype-or-error *class-t-prototype*))
533 moore 1.15 (unless (clim-mop:class-finalized-p ptype-meta)
534     (clim-mop:finalize-inheritance ptype-meta))
535     (or (clim-mop:class-prototype ptype-meta)
536     (error "Couldn't find a prototype for ~S" name))))
537 moore 1.35
538     (defun safe-cpl (class)
539     (unless (clim-mop:class-finalized-p class)
540     (clim-mop:finalize-inheritance class))
541     (clim-mop:class-precedence-list class))
542 moore 1.15
543 moore 1.3 (defun get-ptype (name)
544     (or (gethash name *presentation-type-table*)
545     (let ((meta (find-class name nil)))
546     (and (typep meta 'standard-class)
547     meta))))
548    
549     (defgeneric presentation-ptype-supers (type)
550     (:documentation "Gets a list of the presentation type objects for those
551     supertypes of TYPE that are presentation types"))
552    
553     (defmethod presentation-ptype-supers ((type symbol))
554     (let ((ptype (gethash type *presentation-type-table*)))
555     (if ptype
556     (presentation-ptype-supers ptype)
557     nil)))
558    
559     (defmethod presentation-ptype-supers ((type presentation-type-class))
560     (mapcan #'(lambda (class)
561     (typecase class
562     (presentation-type
563     (list class))
564     (standard-class
565 moore 1.35 (let ((clos-ptype (gethash (class-name class)
566 moore 1.3 *presentation-type-table*)))
567     (if clos-ptype
568     (list clos-ptype)
569     nil)))
570     (t
571     nil)))
572     (clim-mop:class-direct-superclasses type)))
573    
574     (defmethod presentation-ptype-supers ((type clos-presentation-type))
575     (presentation-ptype-supers (clos-class type)))
576    
577 moore 1.67 ;;; External function
578    
579     (defun presentation-type-direct-supertypes (type)
580     (with-presentation-type-decoded (name)
581     type
582     (let ((supers (presentation-ptype-supers name)))
583     (mapcar #'class-presentation-type-name supers))))
584    
585 moore 1.14 (eval-when (:compile-toplevel :load-toplevel :execute)
586     (defmethod ptype-specializer ((type symbol))
587     (let ((ptype (gethash type *presentation-type-table*)))
588 moore 1.55 (cond (ptype
589     (ptype-specializer ptype))
590     ((find-class type nil)
591     (ptype-specializer (find-class type)))
592     ;; Assume it's a forward referenced CLOS class.
593     (t type))))
594 moore 1.3
595 moore 1.14 (defmethod ptype-specializer ((type standard-class))
596 moore 1.35 (class-name type)))
597 moore 1.3
598 moore 1.59 ;;; We need to patch defclass in every implementation to record a CLOS
599     ;;; class at compiletime. On the other hand, I think we can assume
600     ;;; that if a CLOS class exists at compile time, it will exist at
601     ;;; load/run time too.
602 moore 1.14 (eval-when (:compile-toplevel :load-toplevel :execute)
603 moore 1.46 #-(or excl cmu sbcl openmcl)
604 moore 1.14 (defun compile-time-clos-p (name)
605     (let ((meta (find-class name nil)))
606     (and meta
607     (typep meta 'standard-class))))
608    
609 moore 1.46 #+(or excl cmu sbcl openmcl)
610 moore 1.28 (defun compile-time-clos-p (name)
611 moore 1.29 (let ((metaclass (find-class name nil)))
612     (or (and metaclass
613     (typep metaclass 'standard-class))
614     (clim-lisp-patch::compile-time-clos-class-p name))))
615 moore 1.28
616 moore 1.14 (defun make-default-description (name)
617     "Create a description string from the type name"
618     (let ((downcase-name (string-downcase name)))
619     (setq downcase-name (nsubstitute-if-not #\Space
620     #'alphanumericp
621     downcase-name))
622     (string-trim " " downcase-name)))
623    
624     (defun record-presentation-type (name parameters params-ll options options-ll
625     inherit-from-func description history
626     parameters-are-types
627     compile-time-p
628     supers expansion-func)
629     (let* ((fake-name (make-presentation-type-name name))
630     (ptype-class-args (list :type-name name
631     :parameters parameters
632     :parameters-lambda-list params-ll
633     :options options
634     :options-lambda-list options-ll
635     :inherit-from-function inherit-from-func
636     :description description
637     :history history
638     :parameters-are-types parameters-are-types
639     :expansion-function expansion-func))
640     (ptype-meta
641     (if compile-time-p
642     (apply #'make-instance
643     (if (compile-time-clos-p name)
644     'clos-presentation-type
645     'presentation-type)
646     ptype-class-args)
647     (let* ((clos-meta (find-class name nil))
648     (closp (typep clos-meta 'standard-class)))
649     (if closp
650     (apply #'make-instance 'clos-presentation-type
651     :clos-class clos-meta
652     ptype-class-args)
653 moore 1.62 (let ((directs (mapcan
654     #'(lambda (super)
655     (if (eq super t)
656     nil
657     (list (or (get-ptype-metaclass
658     super)
659     super))))
660 moore 1.14 supers)))
661     (apply #'clim-mop:ensure-class fake-name
662     :name fake-name
663     :metaclass 'presentation-type-class
664     :direct-superclasses directs
665     ptype-class-args)))))))
666     (setf (gethash name *presentation-type-table*) ptype-meta)
667     ptype-meta))
668     ); eval-when
669 moore 1.3
670     (defgeneric massage-type-for-super (type-name super-name type-spec)
671     (:documentation "translate TYPE-SPEC from that of TYPE-NAME to one
672     suitable for SUPER-NAME"))
673    
674     ;;; The default: there ain't no direct specification
675    
676     (defmethod massage-type-for-super ((type-name t) (super-name t) type-spec)
677     (declare (ignore type-spec))
678     (values nil nil))
679    
680     ;;; Load-time actions for define-presentation-type
681     (defmacro %define-presentation-type (name parameters params-ll
682     options options-ll
683     inherit-from inherit-from-lambda
684     description history parameters-are-types)
685 moore 1.4 (declare (ignore inherit-from))
686 moore 1.3 (let* ((inherit-from-func (coerce inherit-from-lambda 'function))
687     (inherit-typespec (funcall inherit-from-func
688     (cons name (fake-params-args params-ll))))
689     (superclasses (if inherit-typespec
690     (with-presentation-type-decoded
691     (super-name super-params)
692     inherit-typespec
693     (if (eq super-name 'and)
694     (mapcar #'presentation-type-name super-params)
695     (list super-name)))
696 moore 1.4 nil))
697     (expansion-lambda (make-expansion-lambda params-ll options-ll)))
698 moore 1.3 `(progn
699     (record-presentation-type ',name ',parameters ',params-ll ',options
700     ',options-ll #',inherit-from-lambda
701     ',description ',history
702     ',parameters-are-types
703 moore 1.4 nil ',superclasses
704     #',expansion-lambda)
705 moore 1.3 ,@(cond ((eq (presentation-type-name inherit-typespec) 'and)
706     (loop for super in superclasses
707     for i from 0
708     append (unless (or (not (atom super))
709     (eq super 'satisfies)
710     (eq super 'not))
711     `((defmethod massage-type-for-super
712     ((type-name (eql ',name))
713     (super-name (eql ',super))
714     type)
715     (values (nth ,i
716     (cdr (,inherit-from-lambda
717     type)))
718     t))))))
719     (superclasses
720     `((defmethod massage-type-for-super
721     ((type-name (eql ',name))
722     (super-name (eql ',(car superclasses)))
723     type)
724     (values (,inherit-from-lambda type) t))))
725     (t nil)))))
726    
727 adejneka 1.2 (defmacro define-presentation-type (name parameters
728 moore 1.5 &key options inherit-from
729     (description
730     (make-default-description name))
731     (history t)
732     parameters-are-types)
733 moore 1.3 (let* ((params-ll (transform-parameters-lambda-list parameters))
734     (options-ll (transform-options-lambda-list options))
735     (inherit-from-func (make-inherit-from-lambda params-ll
736     options-ll
737 moore 1.4 inherit-from)))
738 moore 1.3 `(progn
739     (eval-when (:compile-toplevel)
740     (record-presentation-type ',name ',parameters ',params-ll ',options
741     ',options-ll #',inherit-from-func
742     ',description ',history
743     ',parameters-are-types
744 moore 1.4 t nil nil))
745 moore 1.3 (eval-when (:load-toplevel :execute)
746     (%define-presentation-type ,name ,parameters ,params-ll
747     ,options ,options-ll
748     ,inherit-from ,inherit-from-func
749 moore 1.5 ,description ,history
750     ,parameters-are-types)))))
751 moore 1.3
752 moore 1.34 ;;; These are used by the presentation method MOP code, but are
753     ;;; actually defined in presentation-defs.lisp after the forms for these
754     ;;; types are executed.
755    
756     (defvar *ptype-t-class*)
757    
758     (defvar *ptype-expression-class*)
759    
760     (defvar *ptype-form-class*)
761    
762 moore 1.4 (defun presentation-type-parameters (type-name &optional env)
763 moore 1.3 (declare (ignore env))
764     (let ((ptype (gethash type-name *presentation-type-table*)))
765     (unless ptype
766     (error "~S is not the name of a presentation type" type-name))
767     (parameters ptype)))
768    
769 moore 1.4 (defun presentation-type-options (type-name &optional env)
770 moore 1.3 (declare (ignore env))
771     (let ((ptype (gethash type-name *presentation-type-table*)))
772     (unless ptype
773     (error "~S is not the name of a presentation type" type-name))
774     (options ptype)))
775    
776     (defmacro with-presentation-type-parameters ((type-name type) &body body)
777 moore 1.37 (let ((ptype (get-ptype type-name)))
778 moore 1.55 (unless (or ptype (compile-time-clos-p type-name))
779     (warn "~S is not a presentation type name." type-name))
780 moore 1.37 (if (typep ptype 'presentation-type)
781     (let* ((params-ll (parameters-lambda-list ptype))
782     (params (gensym "PARAMS"))
783     (type-var (gensym "TYPE-VAR"))
784     (ignorable-vars (get-all-params params-ll)))
785     `(let ((,type-var ,type))
786     (unless (eq ',type-name (presentation-type-name ,type-var))
787     (error "Presentation type specifier ~S does not match the name ~S"
788     ,type-var
789     ',type-name))
790     (let ((,params (decode-parameters ,type-var)))
791     (declare (ignorable ,params))
792     (destructuring-bind ,params-ll ,params
793     (declare (ignorable ,@ignorable-vars))
794     ,@body))))
795     `(let ()
796     ,@body))))
797    
798 moore 1.3
799     (defmacro with-presentation-type-options ((type-name type) &body body)
800 moore 1.37 (let ((ptype (get-ptype type-name)))
801 moore 1.55 (unless (or ptype (compile-time-clos-p type-name))
802     (warn "~S is not a presentation type name." type-name))
803 moore 1.37 (if (typep ptype 'presentation-type)
804     (let* ((options-ll (options-lambda-list ptype))
805     (options (gensym "OPTIONS"))
806     (type-var (gensym "TYPE-VAR"))
807     (ignorable-vars (get-all-params options-ll)))
808     `(let ((,type-var ,type))
809     (unless (eq ',type-name (presentation-type-name ,type-var))
810     (error "Presentation type specifier ~S does not match the name ~S"
811     ,type-var
812     ',type-name))
813     (let ((,options (decode-options ,type-var)))
814     (declare (ignorable ,options))
815     (destructuring-bind ,options-ll ,options
816     (declare (ignorable ,@ignorable-vars))
817     ,@body))))
818     `(let ()
819     ,@body))))
820 moore 1.3
821 moore 1.14 (eval-when (:compile-toplevel :load-toplevel :execute)
822     (defvar *presentation-type-abbreviations* (make-hash-table :test #'eq)))
823 moore 1.3
824     (defmacro define-presentation-type-abbreviation (name parameters
825     equivalent-type
826     &key options)
827     `(eval-when (:compile-toplevel :load-toplevel :execute)
828     (setf (gethash ',name *presentation-type-abbreviations*)
829     #',(make-inherit-from-lambda
830     (transform-parameters-lambda-list parameters)
831     (transform-options-lambda-list options)
832     equivalent-type))))
833    
834     (defun make-type-spec (name parameters options)
835     (cond (options
836     `((,name ,@parameters) ,@options))
837     (parameters
838     `(,name ,@parameters))
839     (t name)))
840    
841     (defun expand-presentation-type-abbreviation-1 (type &optional env)
842     (flet ((expand-list (specs)
843     (loop with expand-any-p = nil
844     for spec in specs
845     collect (multiple-value-bind (expansion expanded)
846     (expand-presentation-type-abbreviation-1 spec env)
847     (setq expand-any-p (or expand-any-p expanded))
848     expansion)
849     into new-params
850     finally (return (if expand-any-p
851     (values new-params t)
852     (values specs nil))))))
853     (with-presentation-type-decoded (name parms options)
854     type
855     (case name
856     ((and or sequence sequence-enumerated)
857     (multiple-value-bind (expansion expanded)
858     (expand-list parms)
859     (if expanded
860     (values (make-type-spec name expansion options) t)
861     (values type nil))))
862     (t (let* ((expander (gethash name *presentation-type-abbreviations*)))
863 moore 1.5 (flet ((copy-description (expanded-typespec)
864     (with-presentation-type-decoded (expand-name
865     expand-params
866     expand-options)
867     expanded-typespec
868     (let ((description (getf options :description))
869     (expand-desc (getf expand-options :description)))
870     (if (and description
871     (null expand-desc))
872     (make-type-spec expand-name
873     expand-params
874     `(:description ,description
875     ,@expand-options))
876     expanded-typespec)))))
877     (if expander
878     (values (copy-description (funcall expander type)) t)
879     (values type nil)))))))))
880    
881 moore 1.3
882     (defun expand-presentation-type-abbreviation (type &optional env)
883     (let ((expand-any-p nil))
884     (loop
885     (multiple-value-bind (expansion expanded)
886     (expand-presentation-type-abbreviation-1 type env)
887     (if expanded
888     (progn
889     (setq expand-any-p t)
890     (setq type expansion))
891     (return (values type expand-any-p)))))))
892    
893     (defun make-presentation-type-specifier (name-and-params &rest options)
894     (with-presentation-type-decoded (name)
895     name-and-params
896 moore 1.4 (let ((ptype (gethash name *presentation-type-table*)))
897     (unless ptype
898     (return-from make-presentation-type-specifier name-and-params))
899     (with-presentation-type-decoded (name parameters defaults)
900     (funcall (expansion-function ptype) name-and-params)
901     (declare (ignore name parameters))
902     (loop for (key val) on options by #'cddr
903     for default = (getf defaults key)
904     unless (equal val default)
905     nconc (list key val) into needed-options
906     finally (return (if needed-options
907     `(,name-and-params ,@needed-options)
908     name-and-params)))))))
909    
910 moore 1.34 ;;; Presentation methods.
911     ;;;
912     ;;; The basic dispatch is performed via CLOS instances that are standins
913     ;;; for the presentation types. There are a couple of complications to
914 moore 1.59 ;;; this simple plan. First, methods on the presentation type class
915     ;;;STANDARD-OBJECT -- if there are any -- should not be applicable to
916     ;;;presentation types that are not CLOS classes, even though STANDARD-OBJECT
917     ;;;is in the class precedence list of the standin object. Our own methods on
918     ;;;COMPUTE-APPLICABLE-METHODS-USING-CLASSES and COMPUTE-APPLICABLE-METHODS
919     ;;;remove methods specialized on standard-object.
920 moore 1.34 ;;;
921     ;;; The second major complication is the whole raison d'etre of presentation
922     ;;; type methods: type parameters and options are massaged so that
923     ;;; applicable methods written on the supertype of a presentation type get
924     ;;; parameters and options in the expected form. "Real" CLIM apparently
925     ;;; does this massaging in the body of the effective method and passes the
926     ;;; massaged parameters as an argument into the method. We do it with a
927     ;;; function call within the body of the method. This is potentially more
928     ;;; expensive, but caching should help that. Our method has the huge
929     ;;; advantage of working with any method combination.
930    
931     (defclass presentation-gf-info ()
932     ((generic-function-name :accessor generic-function-name
933     :initarg :generic-function-name)
934     (lambda-list :accessor lambda-list :initarg :lambda-list)
935     (type-key-arg :accessor type-key-arg :initarg :type-key-arg)
936     (parameters-arg :accessor parameters-arg :initarg :parameters-arg
937     :initform nil)
938     (options-arg :accessor options-arg :initarg :options-arg :initform nil)
939     (type-arg-position :accessor type-arg-position
940     :initarg :type-arg-position)))
941    
942     (defvar *presentation-gf-table* (make-hash-table :test #'eq))
943    
944     (defclass presentation-generic-function (standard-generic-function)
945     ()
946     (:metaclass clim-mop:funcallable-standard-class))
947    
948 moore 1.59 (defvar *standard-object-class* (find-class 'standard-object))
949 moore 1.34
950 tmoore 1.75 #-scl
951 moore 1.59 (defmethod clim-mop:compute-applicable-methods-using-classes :around
952 moore 1.34 ((gf presentation-generic-function) classes)
953 moore 1.59 (multiple-value-bind (methods success)
954     (call-next-method)
955     (let ((ptype-class (car classes)))
956     (if (or (null success)
957     (not (typep ptype-class 'presentation-type-class)))
958     (values methods success)
959     (values (remove-if #'(lambda (method)
960     (eq (car (clim-mop:method-specializers
961     method))
962     *standard-object-class*))
963     methods)
964     t)))))
965 tmoore 1.75
966     #+scl
967     (defmethod clim-mop:compute-applicable-methods-using-classes :around
968     ((gf presentation-generic-function) classes)
969     (multiple-value-bind (methods success non-class-positions)
970     (call-next-method)
971     (let ((ptype-class (car classes)))
972     (if (or (null success)
973     (not (typep ptype-class 'presentation-type-class)))
974     (values methods non-class-positions non-class-positions)
975     (values (remove-if #'(lambda (method)
976     (eq (car (clim-mop:method-specializers
977     method))
978     *standard-object-class*))
979     methods)
980     t
981     non-class-positions)))))
982    
983 moore 1.34 (defun method-applicable (method arguments)
984     (loop for arg in arguments
985     for specializer in (clim-mop:method-specializers method)
986     always (cond ((typep specializer 'clim-mop:eql-specializer)
987     (eql arg (clim-mop:eql-specializer-object specializer)))
988     ((typep arg specializer)
989     t)
990     ((and (not (typep (class-of arg)
991     'presentation-type-class))
992     (or (eq specializer *ptype-form-class*)
993     (eq specializer *ptype-expression-class*)))
994     t)
995     (t nil))))
996    
997 moore 1.61 (defmethod compute-applicable-methods :around
998 moore 1.34 ((gf presentation-generic-function) arguments)
999 moore 1.59 (let ((methods (call-next-method)))
1000     (if (typep (class-of (car arguments)) 'presentation-type-class)
1001     (remove-if #'(lambda (method)
1002     (eq (car (clim-mop:method-specializers method))
1003     *standard-object-class*))
1004     methods)
1005     methods)))
1006 moore 1.3
1007     ;;; The hard part of presentation methods: translating the type specifier for
1008     ;;; superclasses.
1009     ;;;
1010    
1011     (defmethod type-name ((type standard-class))
1012 moore 1.35 (class-name type))
1013 moore 1.3
1014 moore 1.4 (defmethod expansion-function ((type standard-class))
1015     #'(lambda (typespec)
1016     (with-presentation-type-decoded (name)
1017     typespec
1018     name)))
1019    
1020 mikemac 1.16 (defmethod presentation-ptype-supers ((type standard-class))
1021     (mapcan #'(lambda (class)
1022 moore 1.35 (let ((ptype (gethash (class-name class)
1023 mikemac 1.16 *presentation-type-table*)))
1024     (and ptype (list ptype))))
1025     (clim-mop:class-direct-superclasses type)))
1026    
1027 moore 1.3 (defun translate-specifier-for-type (type-name super-name specifier)
1028     (when (eq type-name super-name)
1029 moore 1.4 (return-from translate-specifier-for-type (values specifier t)))
1030 moore 1.3 (multiple-value-bind (translation found)
1031     (massage-type-for-super type-name super-name specifier)
1032     (when found
1033     (return-from translate-specifier-for-type (values translation t))))
1034     (loop for super in (presentation-ptype-supers type-name)
1035     do (multiple-value-bind (translation found)
1036     (translate-specifier-for-type (type-name super)
1037     super-name
1038     (massage-type-for-super
1039     type-name
1040     (type-name super)
1041     specifier))
1042     (when found
1043     (return-from translate-specifier-for-type (values translation
1044     t)))))
1045 moore 1.4 (values super-name nil))
1046 moore 1.3
1047     ;;; XXX can options be specified without parameters? I think not.
1048     (defmacro define-presentation-generic-function (generic-function-name
1049     presentation-function-name
1050     lambda-list
1051     &rest options)
1052     (let ((type-key-arg (car lambda-list))
1053     (parameters-arg (cadr lambda-list))
1054     (options-arg (caddr lambda-list)))
1055     (unless (or (eq type-key-arg 'type-key) (eq type-key-arg 'type-class))
1056     (error "The first argument in a presentation generic function must be
1057     type-key or type-class"))
1058     (unless (eq parameters-arg 'parameters)
1059     (setq parameters-arg nil))
1060     (unless (eq options-arg 'options)
1061     (setq options-arg nil))
1062     (let* ((gf-lambda-list (cons type-key-arg
1063     (cond (options-arg
1064     (cdddr lambda-list))
1065     (parameters-arg
1066     (cddr lambda-list))
1067     (t (cdr lambda-list)))))
1068     ;; XXX should check that it's required
1069     (type-arg-pos (position 'type gf-lambda-list)))
1070     (unless type-arg-pos
1071     (error "type must appear as an argument in a presentation generic
1072     function lambda list"))
1073     `(progn
1074     (eval-when (:compile-toplevel :load-toplevel :execute)
1075     (setf
1076     (gethash ',presentation-function-name *presentation-gf-table*)
1077 moore 1.34 (make-instance 'presentation-gf-info
1078 moore 1.3 :generic-function-name ',generic-function-name
1079     :lambda-list ',lambda-list
1080     :type-key-arg ',type-key-arg
1081     :parameters-arg ',parameters-arg
1082     :options-arg ',options-arg
1083     :type-arg-position ,type-arg-pos)))
1084 moore 1.34 (defgeneric ,generic-function-name ,gf-lambda-list
1085     (:generic-function-class presentation-generic-function)
1086     ,@options)))))
1087 moore 1.14
1088 moore 1.59 (defun parse-method-body (args)
1089     (loop for arglist on args
1090     for (arg) = arglist
1091     while (atom arg)
1092     collect arg into qualifiers
1093     finally (if (and (consp arglist)
1094     (consp (cdr arglist))
1095     (consp (cadr arglist))
1096     (eq (caadr arglist) 'declare))
1097     (return (values qualifiers arg (cadr arglist) (cddr arglist)))
1098     (return (values qualifiers arg nil (cdr arglist))))))
1099    
1100     (defun type-name-from-type-key (type-key)
1101     (if (symbolp type-key)
1102     't
1103     (type-name (class-of type-key))))
1104 moore 1.3
1105     (defmacro define-presentation-method (name &rest args)
1106 moore 1.4 (when (eq name 'presentation-subtypep)
1107     ;; I feel so unclean!
1108     (return-from define-presentation-method
1109     `(define-subtypep-method ,@args)))
1110 moore 1.3 (let ((gf (gethash name *presentation-gf-table*)))
1111     (unless gf
1112     (error "~S is not a presentation generic function" name))
1113     (with-accessors ((parameters-arg parameters-arg)
1114     (options-arg options-arg))
1115     gf
1116 mikemac 1.8 (multiple-value-bind (qualifiers lambda-list decls body)
1117 moore 1.3 (parse-method-body args)
1118     (let ((type-arg (nth (1- (type-arg-position gf)) lambda-list)))
1119     (unless (consp type-arg)
1120     (error "Type argument in presentation method must be specialized"))
1121     (unless (eq (car type-arg) 'type)
1122     (error "Type argument mismatch with presentation generic function
1123     definition"))
1124     (destructuring-bind (type-var type-name) type-arg
1125     (let* ((method-ll `((,(type-key-arg gf)
1126     ,(ptype-specializer type-name))
1127     ,@(copy-list lambda-list)))
1128     (real-body body)
1129     (massaged-type (gensym "MASSAGED-TYPE")))
1130     (when options-arg
1131     (setq real-body
1132     `((let ((,options-arg (decode-options ,massaged-type)))
1133     (declare (ignorable ,options-arg))
1134     (with-presentation-type-options (,type-name
1135     ,massaged-type)
1136     ,@real-body)))))
1137 moore 1.59 (when parameters-arg
1138 moore 1.3 (setq real-body
1139     `((let ((,parameters-arg (decode-parameters
1140     ,massaged-type)))
1141     (declare (ignorable ,parameters-arg))
1142     (with-presentation-type-parameters (,type-name
1143     ,massaged-type)
1144     ,@real-body)))))
1145     (when (or options-arg parameters-arg)
1146     (setq real-body
1147     `((let ((,massaged-type (translate-specifier-for-type
1148 moore 1.59 (type-name-from-type-key
1149     ,(type-key-arg gf))
1150 moore 1.3 ',type-name
1151     ,type-var)))
1152     ,@real-body))))
1153     (setf (nth (type-arg-position gf) method-ll) type-var)
1154     `(defmethod ,(generic-function-name gf) ,@qualifiers ,method-ll
1155 moore 1.54 ,@(when decls
1156     (list decls))
1157 moore 1.26 (block ,name
1158     ,@real-body)))))))))
1159    
1160 moore 1.4
1161 moore 1.3
1162     (defmacro define-default-presentation-method (name &rest args)
1163     (let ((gf (gethash name *presentation-gf-table*)))
1164     (unless gf
1165     (error "~S is not a presentation generic function" name))
1166 mikemac 1.8 (multiple-value-bind (qualifiers lambda-list decls body)
1167 moore 1.3 (parse-method-body args)
1168     `(defmethod ,(generic-function-name gf) ,@qualifiers (,(type-key-arg gf)
1169     ,@lambda-list)
1170 mikemac 1.8 (declare (ignorable ,(type-key-arg gf))
1171     ,@(cdr decls))
1172 tmoore 1.69 (block ,name
1173     ,@body)))))
1174 moore 1.3
1175 moore 1.64 ;;; Somewhat obsolete, but keep it around for apply-presentation-generic-function.
1176 moore 1.3 (defun %funcall-presentation-generic-function (name gf type-arg-position
1177     &rest args)
1178 moore 1.4 (declare (ignore name))
1179 moore 1.3 (let* ((type-spec (nth (1- type-arg-position) args))
1180 moore 1.15 (ptype-name (presentation-type-name type-spec)))
1181     (apply gf (prototype-or-error ptype-name) args)))
1182    
1183 moore 1.64 ;;; I wonder if this pattern for preserving order of evaluation is
1184     ;;; has a more general use...
1185    
1186     (defmacro funcall-presentation-generic-function (name &rest args)
1187     (let ((gf (gethash name *presentation-gf-table*)))
1188     (unless gf
1189     (error "~S is not a presentation generic function" name))
1190 thenriksen 1.80 (let* ((rebound-args (loop for arg in args
1191     unless (symbolp arg)
1192 thenriksen 1.82 collect (list (gensym "ARG") arg)))
1193 thenriksen 1.80 (gf-name (generic-function-name gf))
1194 thenriksen 1.82 (type-spec-var (nth (1- (type-arg-position gf)) args)))
1195 moore 1.64 `(let ,rebound-args
1196 thenriksen 1.80 (,gf-name (prototype-or-error (presentation-type-name
1197 thenriksen 1.82 ,(or (first (find type-spec-var rebound-args :key #'second))
1198     type-spec-var)))
1199 thenriksen 1.80 ,@(mapcar #'(lambda (arg)
1200     ;; Order of evaluation doesn't matter
1201     ;; for symbols, and this shuts up
1202     ;; warnings about arguments in a
1203     ;; keyword position not being
1204     ;; constant. By the way, why do we
1205     ;; care about order of evaluation
1206     ;; here? -trh
1207     (or (first (find arg rebound-args :key #'second))
1208     arg)) args))))))
1209 moore 1.64
1210 moore 1.3 (defmacro apply-presentation-generic-function (name &rest args)
1211     (let ((gf (gethash name *presentation-gf-table*)))
1212     (unless gf
1213 moore 1.6 (error "~S is not a presentation generic function" name))
1214 moore 1.3 `(apply #'%funcall-presentation-generic-function ',name
1215     #',(generic-function-name gf)
1216     ,(type-arg-position gf)
1217     ,@args)))
1218    
1219 moore 1.33 ;;; 23.7.1 Defining Presentation Translators
1220    
1221     (defclass presentation-translator ()
1222 hefner1 1.51 ((name :reader name :initarg :name)
1223 moore 1.33 (from-type :reader from-type :initarg :from-type)
1224     (to-type :reader to-type :initarg :to-type)
1225     (gesture :reader gesture :initarg :gesture)
1226     (tester :reader tester :initarg :tester)
1227     (tester-definitive :reader tester-definitive :initarg :tester-definitive)
1228     (documentation :reader translator-documentation :initarg :documentation)
1229     (pointer-documentation :reader pointer-documentation
1230     :initarg :pointer-documentation)
1231     (menu :reader menu :initarg :menu)
1232     (priority :reader priority :initarg :priority :initform 0)
1233     (translator-function :reader translator-function
1234     :initarg :translator-function)))
1235    
1236     (defmethod initialize-instance :after ((obj presentation-translator)
1237     &key &allow-other-keys)
1238     (unless (slot-boundp obj 'pointer-documentation)
1239     (setf (slot-value obj 'pointer-documentation)
1240     (translator-documentation obj))))
1241    
1242     (defmethod print-object ((obj presentation-translator) stream)
1243     (print-unreadable-object (obj stream :identity t)
1244 moore 1.37 (format stream "Translator ~S from ~S to ~S"
1245     (name obj) (from-type obj) (to-type obj))))
1246    
1247     (defclass presentation-action (presentation-translator)
1248     ())
1249    
1250     (defmethod initialize-instance :after ((obj presentation-action)
1251     &key &allow-other-keys)
1252     (setf (slot-value obj 'tester-definitive) t))
1253    
1254     (defmethod print-object ((obj presentation-action) stream)
1255     (print-unreadable-object (obj stream :identity t)
1256     (format stream "Action from ~S to ~S" (from-type obj) (to-type obj))))
1257 moore 1.33
1258     ;;; This lives in a command table
1259    
1260 hefner1 1.51 (defvar *current-translator-cache-generation* 0
1261     "This is incremented whenever presentation translators are defined,
1262     and used to ensure that presentation-translators-caches are up to date.")
1263    
1264 moore 1.33 (defclass translator-table ()
1265     ((translators :accessor translators :initarg :translators
1266     :initform (make-hash-table :test #'eq)
1267     :documentation "Translators keyed by name.")
1268     (simple-type-translators :accessor simple-type-translators
1269     :initarg :simple-type-translators
1270     :initform (make-hash-table :test #'eq)
1271     :documentation "Holds transators with a simple
1272     from-type (i.e. doesn't contain \"or\" or \"and\").")
1273 hefner1 1.51 (translator-cache-generation :accessor translator-cache-generation :initform 0)
1274 moore 1.33 (presentation-translators-cache
1275 hefner1 1.51 :writer (setf presentation-translators-cache)
1276 moore 1.33 :initform (make-hash-table :test #'equal))))
1277    
1278 tmoore 1.76 (defun invalidate-translator-caches ()
1279     (incf *current-translator-cache-generation*))
1280    
1281 hefner1 1.51 (defmethod presentation-translators-cache ((table translator-table))
1282     (with-slots ((cache presentation-translators-cache)
1283     (generation translator-cache-generation))
1284     table
1285     (unless (or (= generation *current-translator-cache-generation*)
1286 hefner1 1.52 (zerop (hash-table-size cache)))
1287 hefner1 1.51 (clrhash cache))
1288     (setf generation *current-translator-cache-generation*)
1289     cache))
1290    
1291    
1292    
1293 moore 1.33 ;;; Returns function lambda list, ignore forms
1294     (defun make-translator-ll (translator-args)
1295     (let ((object-arg (find "object" translator-args :test #'string-equal))
1296     (ignore-form nil))
1297     (if object-arg
1298     (setq translator-args (remove "object" translator-args
1299     :test #'string-equal))
1300     (progn
1301     (setq object-arg (gensym "OBJECT-ARG"))
1302     (setq ignore-form `(declare (ignore ,object-arg)))))
1303     (values `(,object-arg &key ,@translator-args &allow-other-keys)
1304     ignore-form)))
1305    
1306     (defun default-translator-tester (object-arg &key &allow-other-keys)
1307     (declare (ignore object-arg))
1308     t)
1309    
1310     (defun add-translator (table translator)
1311     ;; Remove old one.
1312     (with-accessors ((translators translators)
1313     (simple-type-translators simple-type-translators))
1314     table
1315     (let ((old (gethash (name translator) translators)))
1316     (when old
1317     (setf (gethash (presentation-type-name (from-type old))
1318     simple-type-translators)
1319     (remove old
1320     (gethash (presentation-type-name (from-type old))
1321     simple-type-translators))))
1322 tmoore 1.76 (invalidate-translator-caches)
1323 moore 1.33 (setf (gethash (name translator) translators) translator)
1324     (push translator
1325 tmoore 1.76 (gethash (from-type translator) simple-type-translators))
1326     translator)))
1327 moore 1.33
1328 moore 1.37 (defun make-translator-fun (args body)
1329     (multiple-value-bind (ll ignore)
1330     (make-translator-ll args)
1331     `(lambda ,ll
1332     ,@(and ignore (list ignore))
1333     ,@body)))
1334    
1335 moore 1.62 (defun make-documentation-fun (doc-arg)
1336 moore 1.37 (cond ((and doc-arg (symbolp doc-arg))
1337     doc-arg)
1338     ((consp doc-arg)
1339     (make-translator-fun (car doc-arg) (cdr doc-arg)))
1340     ((stringp doc-arg)
1341     `(lambda (object &key stream &allow-other-keys)
1342 moore 1.62 (declare (ignore object))
1343     (write-string ,doc-arg stream)))
1344 moore 1.37 ((null doc-arg)
1345 moore 1.62 `(lambda (object &key presentation stream &allow-other-keys)
1346     (present object (presentation-type presentation)
1347     :stream stream :sensitive nil)))
1348 moore 1.37 (t (error "Can't handle doc-arg ~S" doc-arg))))
1349    
1350 moore 1.33 (defmacro define-presentation-translator
1351 moore 1.63 (name (from-type to-type command-table &rest translator-options &key
1352 moore 1.33 (gesture :select)
1353     (tester 'default-translator-tester testerp)
1354     (tester-definitive (if testerp nil t))
1355 tmoore 1.76 (documentation nil documentationp)
1356 moore 1.33 (pointer-documentation nil pointer-documentation-p)
1357     (menu t)
1358 moore 1.63 (priority 0)
1359     (translator-class 'presentation-translator)
1360     &allow-other-keys)
1361 moore 1.33 arglist
1362     &body body)
1363 tmoore 1.69 ;; null tester should be the same as no tester
1364     (unless tester
1365     (setq tester 'default-translator-tester)
1366     (setq tester-definitive t))
1367 moore 1.37 (let* ((real-from-type (expand-presentation-type-abbreviation from-type))
1368     (real-to-type (expand-presentation-type-abbreviation to-type)))
1369 moore 1.63 (with-keywords-removed (translator-options
1370     (:gesture :tester :tester-definitive :documentation
1371     :pointer-documentation :menu :priority
1372     :translator-class))
1373     `(add-translator (presentation-translators (find-command-table
1374     ',command-table))
1375     (make-instance
1376     ',translator-class
1377     :name ',name
1378     :from-type ',real-from-type
1379     :to-type ',real-to-type
1380     :gesture ,(if (eq gesture t)
1381     t
1382     `(gethash ',gesture *gesture-names*))
1383     :tester ,(if (symbolp tester)
1384     `',tester
1385     `#',(make-translator-fun (car tester)
1386     (cdr tester)))
1387     :tester-definitive ',tester-definitive
1388     :documentation #',(make-documentation-fun
1389 tmoore 1.76 (if documentationp
1390     documentation
1391     (command-name-from-symbol
1392     name)))
1393 moore 1.63 ,@(when pointer-documentation-p
1394     `(:pointer-documentation
1395     #',(make-documentation-fun
1396     pointer-documentation)))
1397     :menu ',menu
1398     :priority ,priority
1399     :translator-function #',(make-translator-fun arglist
1400     body)
1401     ,@translator-options)))))
1402 moore 1.37
1403     (defmacro define-presentation-action
1404     (name (from-type to-type command-table &key
1405     (gesture :select)
1406 moore 1.54 (tester 'default-translator-tester)
1407 tmoore 1.76 (documentation nil documentationp)
1408 moore 1.37 (pointer-documentation nil pointer-documentation-p)
1409     (menu t)
1410     (priority 0))
1411     arglist
1412     &body body)
1413     (let* ((real-from-type (expand-presentation-type-abbreviation from-type))
1414     (real-to-type (expand-presentation-type-abbreviation to-type)))
1415     `(add-translator (presentation-translators (find-command-table
1416     ',command-table))
1417     (make-instance
1418     'presentation-action
1419     :name ',name
1420     :from-type ',real-from-type
1421     :to-type ',real-to-type
1422     :gesture ,(if (eq gesture t)
1423     t
1424     `(gethash ',gesture *gesture-names*))
1425     :tester ,(if (symbolp tester)
1426     `',tester
1427     `#',(make-translator-fun (car tester)
1428     (cdr tester)))
1429 mretzlaff 1.71 :tester-definitive t
1430 tmoore 1.76 :documentation #',(make-documentation-fun (if documentationp
1431     documentation
1432     (command-name-from-symbol
1433     name)))
1434 moore 1.37 ,@(when pointer-documentation-p
1435     `(:pointer-documentation
1436 moore 1.62 #',(make-documentation-fun pointer-documentation)))
1437 moore 1.37 :menu ',menu
1438     :priority ,priority
1439     :translator-function #',(make-translator-fun arglist
1440     body)))))
1441    
1442 moore 1.33 ;;; define-presentation-to-command-translator is in commands.lisp
1443    
1444     ;;; 23.7.2 Presentation Translator Functions
1445    
1446 moore 1.34 ;;; Used by map-over-presentation-type-supertypes as well
1447    
1448     (defun map-over-ptype-superclasses (function type)
1449     (let* ((type-name (presentation-type-name type))
1450 moore 1.59 (type-meta (get-ptype-metaclass type-name))
1451     (type-is-ptype (typep type-meta 'presentation-type-class)))
1452 moore 1.34 (unless type-meta
1453     (return-from map-over-ptype-superclasses nil))
1454 moore 1.59 (loop
1455     for super-meta in (safe-cpl type-meta)
1456     ;; structure classes?
1457     when (and (or (typep super-meta 'standard-class)
1458 moore 1.60 (eq super-meta *builtin-t-class*))
1459 moore 1.59 (not (and type-is-ptype
1460     (eq super-meta *standard-object-class*))))
1461     do (funcall function super-meta))))
1462 moore 1.34
1463 crhodes 1.79 ;;; This is to implement the requirement on presentation translators
1464     ;;; for doing subtype calculations without reference to type
1465     ;;; parameters. We are generous in that we return T when we are
1466     ;;; unsure, to give translator testers a chance to accept or reject
1467     ;;; the translator. This is essentially
1468     ;;; (multiple-value-bind (yesp surep)
1469     ;;; (presentation-subtypep maybe-subtype type)
1470     ;;; (or yesp (not surep)))
1471     ;;; except faster.
1472 moore 1.33 (defun stupid-subtypep (maybe-subtype type)
1473     "Return t if maybe-subtype is a presentation subtype of type, regardless of
1474     parameters."
1475 crhodes 1.79 (when (or (eq maybe-subtype nil) (eq type t))
1476     (return-from stupid-subtypep t))
1477     (when (eql maybe-subtype type)
1478 moore 1.33 (return-from stupid-subtypep t))
1479 moore 1.57 (let ((maybe-subtype-name (presentation-type-name maybe-subtype))
1480     (type-name (presentation-type-name type)))
1481 crhodes 1.79 (cond
1482     ;; see DEFUN PRESENTATION-SUBTYPEP for some caveats
1483     ((eq maybe-subtype-name 'or)
1484     (let ((or-types (decode-parameters maybe-subtype)))
1485     (every (lambda (x) (stupid-subtypep x type)) or-types)))
1486     ((eq type-name 'and)
1487     (stupid-subtypep maybe-subtype (car (decode-parameters type))))
1488     ((eq type-name 'or)
1489     (let ((or-types (decode-parameters type)))
1490     (some (lambda (x) (stupid-subtypep maybe-subtype x)) or-types)))
1491     ((eq maybe-subtype-name 'and)
1492     ;; this clause is actually not conservative, but probably in a
1493     ;; way that no-one will complain about too much. Basically, we
1494     ;; will only return T if the first type in the AND (which is
1495     ;; treated specially by CLIM) is subtypep the maybe-supertype
1496     (stupid-subtypep (car (decode-parameters maybe-subtype)) type))
1497     (t
1498     (let ((subtype-meta (get-ptype-metaclass maybe-subtype-name))
1499     (type-meta (get-ptype-metaclass type-name)))
1500     (unless (and subtype-meta type-meta)
1501     (return-from stupid-subtypep nil))
1502     (map-over-ptype-superclasses #'(lambda (super)
1503     (when (eq type-meta super)
1504     (return-from stupid-subtypep t)))
1505     maybe-subtype-name)
1506     nil)))))
1507 moore 1.33
1508     (defun find-presentation-translators (from-type to-type command-table)
1509 hefner1 1.51 (let* ((command-table (find-command-table command-table))
1510 moore 1.33 (from-name (presentation-type-name from-type))
1511     (to-name (presentation-type-name to-type))
1512     (cached-translators (gethash (cons from-name to-name)
1513     (presentation-translators-cache
1514     (presentation-translators
1515     command-table)))))
1516     (when cached-translators
1517     (return-from find-presentation-translators cached-translators))
1518     (let ((translator-vector (make-array 8 :adjustable t :fill-pointer 0))
1519     (table-counter 0))
1520     (do-command-table-inheritance (table command-table)
1521     (let ((translator-map (simple-type-translators
1522     (presentation-translators table))))
1523     (flet ((get-translators (type)
1524     (let ((translators (gethash type translator-map)))
1525     (loop for translator in translators
1526 moore 1.57 if (stupid-subtypep (to-type translator)
1527     to-type)
1528 moore 1.33 do (vector-push-extend (cons translator
1529     table-counter)
1530     translator-vector)))))
1531 moore 1.34 (map-over-ptype-superclasses #'(lambda (super)
1532     (get-translators (type-name
1533     super)))
1534     from-name)))
1535 moore 1.33 (incf table-counter))
1536 moore 1.34 (let ((from-super-names nil))
1537     (map-over-ptype-superclasses #'(lambda (super)
1538     (push (type-name super)
1539     from-super-names))
1540     from-name)
1541     (setq from-super-names (nreverse from-super-names))
1542 moore 1.33 ;; The Spec mentions "high order priority" and "low order priority"
1543     ;; without saying what that is! Fortunately, the Franz CLIM user guide
1544     ;; says that high order priority is (floor priority 10), low order
1545     ;; priority is (mod priority 10.) That's pretty wacked...
1546     (flet ((translator-lessp (a b)
1547     (destructuring-bind (translator-a . table-num-a)
1548     a
1549     (destructuring-bind (translator-b . table-num-b)
1550     b
1551     (multiple-value-bind (hi-a low-a)
1552     (floor (priority translator-a))
1553     (multiple-value-bind (hi-b low-b)
1554     (floor (priority translator-b))
1555     ;; High order priority
1556     (cond ((> hi-a hi-b)
1557     (return-from translator-lessp t))
1558     ((< hi-a hi-b)
1559     (return-from translator-lessp nil)))
1560     ;; more specific
1561     (let ((a-precedence (position
1562     (presentation-type-name
1563     (from-type translator-a))
1564     from-super-names))
1565     (b-precedence (position
1566     (presentation-type-name
1567     (from-type translator-b))
1568     from-super-names)))
1569     (cond ((< a-precedence b-precedence)
1570     (return-from translator-lessp t))
1571     ((> a-precedence b-precedence)
1572     (return-from translator-lessp nil))))
1573     ;; Low order priority
1574     (cond ((> low-a low-b)
1575     (return-from translator-lessp t))
1576     ((< low-a low-b)
1577     (return-from translator-lessp nil)))))
1578     ;; Command table inheritance
1579     (< table-num-a table-num-b)))))
1580 hefner1 1.51 ;; Add translators to their caches.
1581 moore 1.33 (setf (gethash (cons from-name to-name)
1582     (presentation-translators-cache
1583     (presentation-translators command-table)))
1584 hefner1 1.68 (remove-duplicates
1585     (map 'list
1586     #'car
1587     (sort translator-vector #'translator-lessp)))))))))
1588 moore 1.33
1589 moore 1.37 (defgeneric call-presentation-translator
1590     (translator presentation context-type frame event window x y))
1591    
1592     (defmethod call-presentation-translator
1593     ((translator presentation-translator) presentation context-type
1594     frame event window x y)
1595 tmoore 1.73 ;; Let the translator return an explict ptype of nil to, in effect, abort the
1596     ;; presentation throw.
1597     (multiple-value-call
1598     #'(lambda (object &optional (ptype context-type) options)
1599     (values object ptype options))
1600     (funcall (translator-function translator)
1601     (presentation-object presentation)
1602     :presentation presentation
1603     :context-type context-type
1604     :frame frame
1605     :event event
1606     :window window
1607     :x x
1608     :y y)))
1609 moore 1.33
1610 moore 1.37 (defmethod call-presentation-translator
1611     ((translator presentation-action) presentation context-type
1612     frame event window x y)
1613     (funcall (translator-function translator)
1614     (presentation-object presentation)
1615     :presentation presentation
1616     :context-type context-type
1617     :frame frame
1618     :event event
1619     :window window
1620     :x x
1621     :y y)
1622     (values nil nil nil))
1623 moore 1.33
1624 moore 1.38 (defun document-presentation-translator (translator
1625     presentation
1626     context-type
1627     frame
1628     event
1629     window
1630     x y
1631     &key (stream *standard-output*)
1632     (documentation-type :normal))
1633     (funcall (if (eq documentation-type :normal)
1634     (translator-documentation translator)
1635     (pointer-documentation translator))
1636     (presentation-object presentation)
1637     :presentation presentation
1638     :context-type context-type
1639     :frame frame
1640     :event event
1641     :window window
1642     :x x
1643     :y y
1644     :stream stream))
1645    
1646     ;;; :button is a pointer button state, for performing matches where we want to
1647     ;;; restrict the match to certain gestures but don't have a real event.
1648    
1649 moore 1.33 (defun test-presentation-translator
1650     (translator presentation context-type frame window x y
1651 moore 1.38 &key event (modifier-state 0) for-menu button)
1652 moore 1.33 (flet ((match-gesture (gesture event modifier-state)
1653     (let ((modifiers (if event
1654     (event-modifier-state event)
1655     modifier-state)))
1656     (or (eq gesture t)
1657 moore 1.39 for-menu
1658 moore 1.33 (loop for g in gesture
1659     thereis (and (eql modifiers (caddr g))
1660 moore 1.38 (or (and button (eql button (cadr g)))
1661     (and (null button)
1662     (or (null event)
1663     (eql (pointer-event-button
1664     event)
1665     (cadr g)))))))))))
1666 moore 1.33 (let* ((from-type (from-type translator)))
1667     (unless (match-gesture (gesture translator) event modifier-state)
1668     (return-from test-presentation-translator nil))
1669     (unless (or (null (decode-parameters from-type))
1670     (presentation-typep (presentation-object presentation)
1671     from-type))
1672     (return-from test-presentation-translator nil))
1673     (unless (or (null (tester translator))
1674 moore 1.34 (funcall (tester translator)
1675     (presentation-object presentation)
1676 moore 1.33 :presentation presentation
1677     :context-type context-type
1678     :frame frame
1679     :window window
1680     :x x
1681     :y y
1682     :event event))
1683     (return-from test-presentation-translator nil))
1684     (unless (or (tester-definitive translator)
1685     (null (decode-parameters context-type))
1686     (presentation-typep (call-presentation-translator
1687     translator
1688     presentation
1689     context-type
1690     frame
1691     event
1692     window
1693     x y)
1694     context-type))
1695     (return-from test-presentation-translator nil))))
1696     t)
1697    
1698 tmoore 1.69 ;;; presentation-contains-position moved to presentation-defs.lisp
1699 moore 1.56
1700 moore 1.33 (defun map-over-presentations-containing-position (func record x y)
1701     "maps recursively over all presentations in record, including record."
1702     (map-over-output-records-containing-position
1703     #'(lambda (child)
1704 moore 1.56 (when (output-record-p child) ; ? What else could it be? --moore
1705 moore 1.33 (map-over-presentations-containing-position func child x y))
1706 moore 1.56 #+nil
1707 moore 1.33 (when (presentationp child)
1708     (funcall func child)))
1709     record
1710     x y)
1711     (when (and (presentationp record)
1712 moore 1.56 (presentation-contains-position record x y))
1713 moore 1.33 (funcall func record)))
1714    
1715 moore 1.45 (defvar *null-presentation*)
1716    
1717 moore 1.33 (defun map-applicable-translators (func
1718     presentation input-context frame window x y
1719 moore 1.38 &key event (modifier-state 0)
1720 moore 1.45 for-menu
1721     button)
1722     (flet ((process-presentation (context context-ptype presentation)
1723     (let ((maybe-translators
1724     (find-presentation-translators (presentation-type
1725     presentation)
1726     context-ptype
1727     (frame-command-table
1728     frame))))
1729     (loop for translator in maybe-translators
1730     when (and (or (not for-menu) (eql for-menu (menu translator)))
1731     (test-presentation-translator translator
1732     presentation
1733     context-ptype
1734     frame
1735     window
1736     x y
1737     :event event
1738     :modifier-state
1739     modifier-state
1740     :for-menu for-menu
1741     :button button))
1742     do (funcall func translator presentation context)))))
1743     (if (and (presentationp presentation)
1744     (presentation-subtypep (presentation-type presentation)
1745     'blank-area))
1746     (loop for context in input-context
1747     for (context-ptype) = context
1748     do (process-presentation context context-ptype presentation))
1749     (loop for context in input-context
1750     for (context-ptype) = context
1751     do (map-over-presentations-containing-position
1752     #'(lambda (p)
1753     (process-presentation context context-ptype p))
1754     presentation
1755     x y)))))
1756 moore 1.33
1757 tmoore 1.74 (defun window-modifier-state (window)
1758     "Provides default modifier state for presentation translator functions."
1759     (let ((pointer (port-pointer (port window))))
1760     (pointer-modifier-state pointer)))
1761    
1762 moore 1.33 (defun find-applicable-translators
1763     (presentation input-context frame window x y
1764 tmoore 1.74 &key event (modifier-state (window-modifier-state window)) for-menu fastp)
1765 moore 1.33 (let ((results nil))
1766     (flet ((fast-func (translator presentation context)
1767     (declare (ignore translator presentation context))
1768     (return-from find-applicable-translators t))
1769     (slow-func (translator presentation context)
1770     (push (list translator presentation (input-context-type context))
1771     results)))
1772     (map-applicable-translators (if fastp #'fast-func #'slow-func)
1773     presentation input-context frame window x y
1774     :event event
1775     :modifier-state modifier-state
1776     :for-menu for-menu)
1777     (nreverse results))))
1778    
1779     (defun presentation-matches-context-type
1780     (presentation context-type frame window x y &key event (modifier-state 0))
1781     (let* ((ptype (expand-presentation-type-abbreviation (presentation-type
1782     presentation)))
1783     (ctype (expand-presentation-type-abbreviation context-type))
1784     (translators (find-presentation-translators ptype
1785     ctype
1786     (frame-command-table
1787     frame))))
1788     (loop for translator in translators
1789     if (test-presentation-translator translator
1790     presentation
1791 adejneka 1.36 ctype
1792 moore 1.33 frame
1793     window
1794     x y
1795     :event event
1796     :modifier-state modifier-state)
1797     do (return-from presentation-matches-context-type t))
1798     nil))
1799    
1800     ;;; 23.7.3 Finding Applicable Presentations
1801    
1802     (defun find-innermost-presentation-match
1803 moore 1.38 (input-context top-record frame window x y event modifier-state button)
1804 moore 1.33 "Helper function that implements the \"innermost-smallest\" input-context
1805     presentation matching algorithm. Returns presentation, translator, and
1806     matching input context."
1807     (let ((result nil)
1808     (result-translator nil)
1809     (result-context nil)
1810     (result-size nil))
1811     (map-applicable-translators
1812     #'(lambda (translator presentation context)
1813 adejneka 1.36 (if (and result-context (not (eq result-context context)))
1814 moore 1.33 ;; Return inner presentation
1815     (return-from find-innermost-presentation-match
1816     (values result result-translator result-context))
1817     (multiple-value-bind (min-x min-y max-x max-y)
1818     (output-record-hit-detection-rectangle* presentation)
1819     (let ((size (* (- max-x min-x) (- max-y min-y))))
1820     (when (or (not result) (< size result-size))
1821     (setq result presentation)
1822     (setq result-translator translator)
1823     (setq result-context context)
1824     (setq result-size size))))))
1825     top-record
1826     input-context
1827     frame
1828     window
1829     x y
1830     :event event
1831 moore 1.38 :modifier-state modifier-state
1832     :button button)
1833 moore 1.45 (when result
1834     (return-from find-innermost-presentation-match
1835     (values result result-translator result-context)))
1836     (map-applicable-translators
1837     #'(lambda (translator presentation context)
1838     (return-from find-innermost-presentation-match
1839     (values presentation translator context)))
1840     *null-presentation*
1841     input-context
1842     frame
1843     window
1844     x y
1845     :event event
1846     :modifier-state modifier-state
1847     :button button))
1848     nil)
1849 moore 1.33
1850     (defun find-innermost-applicable-presentation
1851     (input-context window x y
1852 tmoore 1.74 &key (frame *application-frame*)
1853     (modifier-state (window-modifier-state window))
1854     event)
1855 moore 1.33 (values (find-innermost-presentation-match input-context
1856 adejneka 1.36 (stream-output-history window)
1857     frame
1858     window
1859     x y
1860     event
1861 moore 1.38 modifier-state
1862     nil)))
1863    
1864 tmoore 1.74 (defun find-innermost-presentation-context
1865     (input-context window x y
1866     &key (top-record (stream-output-history window))
1867     (frame *application-frame*)
1868     event
1869     (modifier-state (window-modifier-state window))
1870     button)
1871 moore 1.38 (find-innermost-presentation-match input-context
1872 tmoore 1.70 top-record
1873 moore 1.38 frame
1874     window
1875     x y
1876     event
1877     modifier-state
1878     button))
1879 moore 1.33
1880     (defun throw-highlighted-presentation (presentation input-context event)
1881     (let ((x (pointer-event-x event))
1882     (y (pointer-event-y event))
1883     (window (event-sheet event)))
1884     (multiple-value-bind (p translator context)
1885     (find-innermost-presentation-match input-context
1886     presentation
1887     *application-frame*
1888     (event-sheet event)
1889     x y
1890     event
1891 moore 1.38 0
1892     nil)
1893 moore 1.33 (when p
1894     (multiple-value-bind (object ptype options)
1895     (call-presentation-translator translator
1896     p
1897     (input-context-type context)
1898     *application-frame*
1899     event
1900     window
1901     x y)
1902 moore 1.37 (when ptype
1903     (funcall (cdr context) object ptype event options)))))))
1904 tmoore 1.70
1905     (defvar *input-context*)
1906 moore 1.48
1907     (defun throw-object-ptype (object type
1908     &key (input-context *input-context*) sheet)
1909     "Throw an object and presentation type within input-context without
1910     a presentation"
1911     (throw-highlighted-presentation
1912     (make-instance 'standard-presentation
1913 tmoore 1.69 :object object :type type
1914     :single-box t)
1915 moore 1.48 input-context
1916     (make-instance 'pointer-button-press-event
1917     :sheet sheet
1918     :x 0 :y 0
1919     :modifier-state 0
1920     :button +pointer-left-button+)))
1921 moore 1.37
1922 adejneka 1.40 (defstruct presentation-translator-menu-item
1923     translator
1924     presentation
1925     context)
1926    
1927     (defun call-presentation-menu
1928     (presentation input-context frame window x y
1929 moore 1.41 &key (for-menu t) label)
1930 adejneka 1.40 (let (items)
1931     (map-applicable-translators
1932     #'(lambda (translator presentation context)
1933 adejneka 1.42 (push
1934 adejneka 1.43 `(,(make-presentation-translator-menu-item :translator translator
1935     :presentation presentation
1936     :context context)
1937     :documentation ,(with-output-to-string (stream)
1938     (document-presentation-translator
1939     translator
1940     presentation
1941     input-context
1942     frame nil window x y
1943     :stream stream)))
1944 adejneka 1.42 items))
1945     presentation input-context frame window x y :for-menu for-menu)
1946     (when items
1947     (setq items (nreverse items))
1948     (multiple-value-bind (item object event)
1949     (menu-choose items
1950 thenriksen 1.77 :label label
1951 adejneka 1.42 :associated-window window
1952     :printer #'(lambda (item stream)
1953 thenriksen 1.83 (let ((object (first item)))
1954     (document-presentation-translator
1955     (presentation-translator-menu-item-translator object)
1956     (presentation-translator-menu-item-presentation object)
1957     (presentation-translator-menu-item-context object)
1958     frame nil window x y
1959     :stream stream)))
1960 adejneka 1.42 :label label
1961     :pointer-documentation *pointer-documentation-output*)
1962     (declare (ignore object))
1963     (when item
1964     (multiple-value-bind (object ptype options)
1965     (call-presentation-translator (presentation-translator-menu-item-translator item)
1966     (presentation-translator-menu-item-presentation item)
1967     (presentation-translator-menu-item-context item)
1968     frame
1969     event
1970     window
1971     x y)
1972     (when ptype
1973     (funcall (cdr (presentation-translator-menu-item-context item)) object ptype event options))))))))
1974 hefner1 1.50
1975 hefner1 1.53 #+nil
1976 hefner1 1.50 (defmethod highlight-output-record ((record standard-presentation)
1977     stream state)
1978     (map-over-output-records
1979     (lambda (child)
1980     (highlight-output-record child stream state))
1981 thenriksen 1.85 record))
1982    
1983     ;;; Context-dependent input
1984     ;;; An input context is a cons of a presentation type and a continuation to
1985     ;;; call to return a presentation to that input context.
1986    
1987     (defvar *input-context* nil)
1988    
1989     (defun input-context-type (context-entry)
1990     (car context-entry))
1991    
1992     ;;; Many presentation functions, internal and external, take an input
1993     ;;; context as an argument, but they really only need to look at one
1994     ;;; presentation type.
1995     (defun make-fake-input-context (ptype)
1996     (list (cons (expand-presentation-type-abbreviation ptype)
1997     #'(lambda (object type event options)
1998     (declare (ignore event options))
1999     (error "Fake input context called with object ~S type ~S. ~
2000     This shouldn't happen!"
2001     object type)))))
2002    
2003     (defun input-context-wait-test (stream)
2004     (let* ((queue (stream-input-buffer stream))
2005     (event (event-queue-peek queue)))
2006     (when event
2007     (let ((sheet (event-sheet event)))
2008     (when (and (output-recording-stream-p sheet)
2009     (or (typep event 'pointer-event)
2010     (typep event 'keyboard-event))
2011     (not (gadgetp sheet)))
2012     (return-from input-context-wait-test t))))
2013     nil))
2014    
2015     (defun highlight-applicable-presentation (frame stream input-context
2016     &optional (prefer-pointer-window t))
2017     (let* ((queue (stream-input-buffer stream))
2018     (event (event-queue-peek queue)))
2019     (when (and event
2020     (or (and (typep event 'pointer-event)
2021     (or prefer-pointer-window
2022     (eq stream (event-sheet event))))
2023     (typep event 'keyboard-event)))
2024     ;; Stream only needs to see button press events.
2025     ;; XXX Need to think about this more. Should any pointer events be
2026     ;; passed through? If there's no presentation, maybe?
2027     (unless (typep event 'keyboard-event)
2028     (event-queue-read queue))
2029     (progn
2030     (frame-input-context-track-pointer frame
2031     input-context
2032     (event-sheet event)
2033     event)
2034     (when (typep event 'pointer-button-press-event)
2035     (funcall *pointer-button-press-handler* stream event)))
2036     #+nil
2037     (if (and (typep event 'pointer-motion-event)
2038     (pointer-event-button event))
2039     (frame-drag frame input-context (event-sheet event) event)
2040     ))))
2041    
2042     (defun input-context-event-handler (stream)
2043     (highlight-applicable-presentation *application-frame*
2044     stream
2045     *input-context*))
2046    
2047     (defun input-context-button-press-handler (stream button-event)
2048     (declare (ignore stream))
2049     (frame-input-context-button-press-handler *application-frame*
2050     (event-sheet button-event)
2051     button-event))
2052    
2053     (defun highlight-current-presentation (frame input-context)
2054     (let ((event (synthesize-pointer-motion-event (port-pointer
2055     (port
2056     *application-frame*)))))
2057     (when event
2058     (frame-input-context-track-pointer frame
2059     input-context
2060     (event-sheet event)
2061     event))))
2062    
2063     (defmacro with-input-context ((type &key override)
2064     (&optional (object-var (gensym))
2065     (type-var (gensym))
2066     event-var
2067     options-var)
2068     form
2069     &body pointer-cases)
2070     (let ((vars `(,object-var
2071     ,type-var
2072     ,@(and event-var `(,event-var))
2073     ,@(and options-var `(,options-var))))
2074     (return-block (gensym "RETURN-BLOCK"))
2075     (context-block (