Index: builtin-commands.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/builtin-commands.lisp,v
retrieving revision 1.25
diff -u -r1.25 builtin-commands.lisp
--- builtin-commands.lisp	8 Nov 2006 01:18:22 -0000	1.25
+++ builtin-commands.lisp	9 Jan 2007 14:10:31 -0000
@@ -93,9 +93,19 @@
     (t nil global-command-table
      :gesture :select
      :tester ((presentation context-type)
-	      (presentation-subtypep (presentation-type presentation)
-				     context-type))
-     :tester-definitive t
+              ;; This is an approximation; I think the question we
+              ;; should really be asking is "do the presentation and
+              ;; context-type intersect?", which we could do by asking
+              ;; (presentation-subtypep `(and ,ptype ,ctype) nil).
+              ;; However, in practice, this would always return NIL,
+              ;; NIL, not helping at all.  So instead we reject
+              ;; presentations with types that are definitely not
+              ;; subtypes of the context-type.
+              (multiple-value-bind (yp sp)
+                  (presentation-subtypep (presentation-type presentation)
+                                         context-type)
+                (or yp (not sp))))
+     :tester-definitive nil
      :menu nil
      :documentation ((object presentation context-type frame event window x y stream)
                      (let* ((type (presentation-type presentation))
@@ -116,6 +126,10 @@
                                     :stream stream
                                     :sensitive nil)))))
   (object presentation)
+  ;; returning (PRESENTATION-TYPE PRESENTATION) as the ptype is
+  ;; formally undefined, as this means that the translator returns a
+  ;; presentation type which is not PRESENTATION-SUBTYPEP the
+  ;; translator's TO-TYPE.
   (values object (presentation-type presentation)))
 
 (define-presentation-action presentation-menu
Index: presentation-defs.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/presentation-defs.lisp,v
retrieving revision 1.67
diff -u -r1.67 presentation-defs.lisp
--- presentation-defs.lisp	9 Jan 2007 03:39:09 -0000	1.67
+++ presentation-defs.lisp	9 Jan 2007 14:10:32 -0000
@@ -163,30 +163,65 @@
 		 ,@body))))))))
 
 (defun presentation-subtypep (type maybe-supertype)
-  (when (equal type maybe-supertype)
+  ;; special shortcuts: the universal subtype is privileged (and
+  ;; doesn't in fact fit into a hierarchical lattice); the universal
+  ;; supertype is easy to identify.
+  (when (or (eql type nil) (eql maybe-supertype t))
+    (return-from presentation-subtypep (values t t)))
+  (when (eql type maybe-supertype)
     (return-from presentation-subtypep (values t t)))
   (with-presentation-type-decoded (super-name super-parameters)
-    maybe-supertype
-    (when (eq super-name 'or)
-      (loop for or-type in super-parameters
-	    when (presentation-subtypep type or-type)
-	    do (return-from presentation-subtypep (values t t))
-	    finally (return-from presentation-subtypep (values nil t))))
-    (when (eq super-name 'satisfies)
-      (return-from presentation-subtypep (values nil nil)))
-    (with-presentation-type-decoded (sub-name sub-parameters)
-      type
-       (when (eq sub-name 'and)
-	 (loop for and-type in sub-parameters
-	       with subtypep and knownp
-	       with answer-knownp = t
-	       do (multiple-value-setq (subtypep knownp)
-		      (presentation-subtypep and-type maybe-supertype))
-	       if subtypep
-		 do (return-from presentation-subtypep (values t t))
-	       else			; track whether we know the answer
-		 do (setf answer-knownp (and answer-knownp knownp))
-	       finally (return-from presentation-subtypep (values nil answer-knownp)))))
+      maybe-supertype
+    (with-presentation-type-decoded (type-name type-parameters)
+        type
+      (cond
+        ;; DO NOT BE TEMPTED TO REARRANGE THESE CLAUSES
+        ((eq type-name 'or)
+         (dolist (or-type type-parameters 
+                  (return-from presentation-subtypep (values t t)))
+           (multiple-value-bind (yesp surep)
+               (presentation-subtypep or-type maybe-supertype)
+             (unless yesp
+               (return-from presentation-subtypep (values yesp surep))))))
+        ((eq super-name 'and)
+         (let ((result t))
+           (dolist (and-type super-parameters 
+                    (return-from presentation-subtypep (values result result)))
+             (cond
+               ((and (consp and-type) (eq (car and-type) 'satisfies))
+                (setq result nil))
+               ((and (consp and-type) (eq (car and-type) 'not))
+                (multiple-value-bind (yp sp)
+                    (presentation-subtypep type (cadr and-type))
+                  (if yp
+                      (return-from presentation-subtypep (values nil t))
+                      (setq result nil))))
+               (t (multiple-value-bind (yp sp)
+                      (presentation-subtypep type and-type)
+                    (unless yp
+                      (if sp
+                          (return-from presentation-subtypep (values nil t))
+                          (setq result nil)))))))))
+        ((eq super-name 'or)
+         ;; FIXME: this would be the right method were it not for the
+         ;; fact that there can be unions 'in disguise' in the
+         ;; subtype; examples: 
+         ;;   (PRESENTATION-SUBTYPEP 'NUMBER '(OR REAL COMPLEX))
+         ;;   (PRESENTATION-SUBTYPEP '(INTEGER 3 6)
+         ;;                          '(OR (INTEGER 2 5) (INTEGER 4 7)))
+         ;; Sorry about that.
+         (let ((surep t))
+           (dolist (or-type super-parameters 
+                    (return-from presentation-subtypep (values nil surep)))
+             (multiple-value-bind (yp sp)
+                 (presentation-subtypep type or-type)
+               (cond
+                 (yp (return-from presentation-subtypep (values t t)))
+                 ((not sp) (setq surep nil)))))))
+        ((eq type-name 'and)
+         (multiple-value-bind (yp sp)
+             (presentation-subtypep (car type-parameters) maybe-supertype)
+           (return-from presentation-subtypep (values yp yp))))))
     (map-over-presentation-type-supertypes
      #'(lambda (name massaged)
 	 (when (eq name super-name)
Index: presentations.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/presentations.lisp,v
retrieving revision 1.78
diff -u -r1.78 presentations.lisp
--- presentations.lisp	13 Dec 2006 19:35:01 -0000	1.78
+++ presentations.lisp	9 Jan 2007 14:10:32 -0000
@@ -1419,30 +1419,50 @@
 			   (eq super-meta *standard-object-class*))))
        do (funcall function super-meta))))
 
+;;; This is to implement the requirement on presentation translators
+;;; for doing subtype calculations without reference to type
+;;; parameters.  We are generous in that we return T when we are
+;;; unsure, to give translator testers a chance to accept or reject
+;;; the translator.  This is essentially 
+;;;   (multiple-value-bind (yesp surep)
+;;;       (presentation-subtypep maybe-subtype type)
+;;;     (or yesp (not surep)))
+;;; except faster.
 (defun stupid-subtypep (maybe-subtype type)
   "Return t if maybe-subtype is a presentation subtype of type, regardless of
   parameters."
-  (when (or (eq maybe-subtype nil)
-	    (eq type t)
-	    (equal maybe-subtype type))
+  (when (or (eq maybe-subtype nil) (eq type t))
+    (return-from stupid-subtypep t))
+  (when (eql maybe-subtype type)
     (return-from stupid-subtypep t))
   (let ((maybe-subtype-name (presentation-type-name maybe-subtype))
 	(type-name (presentation-type-name type)))
-    (when (eq type-name 'or)
-      (loop for or-type in (decode-parameters type)
-	    when (stupid-subtypep maybe-subtype or-type)
-	    do (return-from stupid-subtypep t)
-	    finally (return-from stupid-subtypep nil)))
-    (let ((subtype-meta (get-ptype-metaclass maybe-subtype-name))
-	  (type-meta (get-ptype-metaclass type-name)))
-      (unless (and subtype-meta type-meta)
-	(return-from stupid-subtypep nil))
-      (map-over-ptype-superclasses #'(lambda (super)
-				       (when (eq type-meta super)
-					 (return-from stupid-subtypep t)))
-				   maybe-subtype-name)
-      nil)))
-
+    (cond
+      ;; see DEFUN PRESENTATION-SUBTYPEP for some caveats
+      ((eq maybe-subtype-name 'or)
+       (let ((or-types (decode-parameters maybe-subtype)))
+         (every (lambda (x) (stupid-subtypep x type)) or-types)))
+      ((eq type-name 'and)
+       (stupid-subtypep maybe-subtype (car (decode-parameters type))))
+      ((eq type-name 'or)
+       (let ((or-types (decode-parameters type)))
+         (some (lambda (x) (stupid-subtypep maybe-subtype x)) or-types)))
+      ((eq maybe-subtype-name 'and)
+       ;; this clause is actually not conservative, but probably in a
+       ;; way that no-one will complain about too much.  Basically, we
+       ;; will only return T if the first type in the AND (which is
+       ;; treated specially by CLIM) is subtypep the maybe-supertype
+       (stupid-subtypep (car (decode-parameters maybe-subtype)) type))
+      (t
+       (let ((subtype-meta (get-ptype-metaclass maybe-subtype-name))
+             (type-meta (get-ptype-metaclass type-name)))
+         (unless (and subtype-meta type-meta)
+           (return-from stupid-subtypep nil))
+         (map-over-ptype-superclasses #'(lambda (super)
+                                          (when (eq type-meta super)
+                                            (return-from stupid-subtypep t)))
+                                      maybe-subtype-name)
+         nil)))))
 
 (defun find-presentation-translators (from-type to-type command-table)
   (let* ((command-table (find-command-table command-table))	 
Index: Tests/presentation-types.lisp
===================================================================
RCS file: Tests/presentation-types.lisp
diff -N Tests/presentation-types.lisp
--- /dev/null	1 Jan 1970 00:00:00 -0000
+++ Tests/presentation-types.lisp	9 Jan 2007 14:10:32 -0000
@@ -0,0 +1,97 @@
+(in-package :clim-tests)
+
+(defparameter *presentation-type-supertypes*
+  '(;; 23.8.1
+    (t)
+    ;; NIL is a special case
+    (null t) (boolean t) (symbol t) (keyword symbol t) (blank-area t)
+    ;; 23.8.2
+    (number t) (complex number t) (real number t) (rational real number t)
+    (integer rational real number t) (ratio rational real number t)
+    (float real number t)
+    ;; 23.8.3
+    (character t) (string t)
+    ;; 23.8.4
+    (pathname t)
+    ;; 23.8.5
+    ((completion nil) t)
+    ;; not allowed abbreviations
+    ;; (member t) ((member-sequence nil) t) ((member-alist nil) t)
+    ((subset-completion nil) t)
+    ;; (subset t) ((subset-sequence nil) t) ((subset-alist nil) t)
+    ;; 23.8.6
+    ((sequence t) t) (sequence-enumerated t)
+    ;; 23.8.7
+    ;;   OR, AND
+    ;; 23.8.8
+    ;;   ((token-or-type nil t) t) ((null-or-type t) t) ((type-or-string t) t)
+    ;; 23.8.9
+    (expression t)
+    (form expression t)))
+
+(defun expect-t-t (type supertype)
+  (multiple-value-bind (yesp surep)
+      (presentation-subtypep type supertype)
+    (assert yesp)
+    (assert surep))
+  #+mcclim
+  ;; we can do this because *presentation-type-supertypes* doesn't do
+  ;; clever things with type parameters
+  (assert (climi::stupid-subtypep type supertype)))
+
+(defun expect-nil-t (type supertype)
+  (multiple-value-bind (yesp surep)
+      (presentation-subtypep type supertype)
+    (assert (not yesp))
+    (assert surep))
+  #+mcclim
+  (assert (not (climi::stupid-subtypep type supertype))))
+
+(defun expect-nil-nil (type supertype)
+  (multiple-value-bind (yesp surep)
+      (presentation-subtypep type supertype)
+    (assert (not yesp))
+    (assert (not surep)))
+  ;; stupid-subtypep must be conservative in what it reports as
+  ;; possibly acceptable.
+  #+mcclim
+  (assert (climi::stupid-subtypep type supertype)))
+            
+(loop for (type . supertypes) in *presentation-type-supertypes*
+      do (expect-t-t type type)
+      do (expect-t-t nil type)
+      ;; if presentation types were "real" (FIXME: work out what
+      ;; "real" means) types, then this wouldn't actually be true.
+      ;; However, PRESENTATION-SUBTYPEP works by walking up the type
+      ;; lattice until it finds a match, and only then checks the type
+      ;; parameters.  So even though presentation types (or
+      ;; abbreviations) like (MEMBER) actually denote the empty set,
+      ;; they are not PRESENTATION-SUBTYPEP NIL.
+      do (expect-nil-t type nil)
+      do (mapcar (lambda (x) (expect-t-t type x)) supertypes))
+
+(loop for (type) in *presentation-type-supertypes*
+      do (expect-t-t type `(and ,type))
+      do (expect-t-t `(and ,type) type)
+      do (expect-t-t `(and ,type) `(and ,type))
+      do (expect-t-t type `(or ,type))
+      do (expect-t-t `(or ,type) type)
+      do (expect-t-t `(or ,type) `(or ,type))
+      do (expect-t-t `(or ,type) `(and ,type))
+      do (expect-t-t `(and ,type) `(or ,type)))
+
+(defun constantly-t (object)
+  (declare (ignore object))
+  t)
+
+(loop for (type) in *presentation-type-supertypes*
+      do (expect-t-t `(and ,type (satisfies constantly-t)) type)
+      do (expect-nil-nil type `(and ,type (satisfies constantly-t)))
+      do (expect-t-t `(and ,type (not nil)) type)
+      do (expect-nil-nil type `(and ,type (not nil))))
+
+(expect-t-t '(or integer symbol) '(or integer symbol))
+(expect-t-t '(or integer symbol) '(or symbol integer))
+
+(expect-t-t '(or real complex) 'number)
+#+nil (expect-t-t 'number '(or real complex))
