* lisp/emacs-lisp/cl-macs.el: Improve type->predicate mapping.

(cl--macroexp-fboundp): New function.
(cl--make-type-test): Use it.

Fixes: debbugs:16520

2 files changed, 23 insertions, 2 deletions

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 962fbcf89d9..738fe6d37be 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,9 @@
+2014-01-23  Stefan Monnier  <monnier@iro.umontreal.ca>
+
+        * emacs-lisp/cl-macs.el: Improve type->predicate mapping (bug#16520).
+        (cl--macroexp-fboundp): New function.
+        (cl--make-type-test): Use it.
+
 2014-01-23  Glenn Morris  <rgm@gnu.org>
 
         * emacs-lisp/lisp-mode.el (eval-print-last-sexp, eval-last-sexp):
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index bfc4f69a56b..45448ecf5dc 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2588,6 +2588,17 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc."
      (put ',name 'cl-deftype-handler
           (cl-function (lambda (&cl-defs '('*) ,@arglist) ,@body)))))
 
+(defvar byte-compile-function-environment)
+(defvar byte-compile-macro-environment)
+
+(defun cl--macroexp-fboundp (sym)
+  "Return non-nil if SYM will be bound when we run the code.
+Of course, we really can't know that for sure, so it's just a heuristic."
+  (or (fboundp sym)
+      (and (cl--compiling-file)
+           (or (cdr (assq sym byte-compile-function-environment))
+               (cdr (assq sym byte-compile-macro-environment))))))
+
 (defun cl--make-type-test (val type)
   (if (symbolp type)
       (cond ((get type 'cl-deftype-handler)
@@ -2603,8 +2614,12 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc."
             (t
              (let* ((name (symbol-name type))
                     (namep (intern (concat name "p"))))
-               (if (fboundp namep) (list namep val)
-                 (list (intern (concat name "-p")) val)))))
+               (cond
+                ((cl--macroexp-fboundp namep) (list namep val))
+                ((cl--macroexp-fboundp
+                  (setq namep (intern (concat name "-p"))))
+                 (list namep val))
+                (t (list type val))))))
     (cond ((get (car type) 'cl-deftype-handler)
            (cl--make-type-test val (apply (get (car type) 'cl-deftype-handler)
                                          (cdr type))))