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

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

Fixes: debbugs:16520

diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 962fbcf89d97db587a0977a3f83e07ee060a67de..738fe6d37be31f5894448e70035809afc4ab922b 100644 (file)
--- 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 bfc4f69a56b91651b377f2fd3da82dfb03771b56..45448ecf5dc85c478c23c7cb2a38df22b35617fd 100644 (file)
--- 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))))