[Emacs-diffs] trunk r116129: * lisp/emacs-lisp/cl-macs.el: Improve type->predicate mapping.

[Stefan Monnier]

------------------------------------------------------------
revno: 116129
revision-id: address@hidden
parent: address@hidden
fixes bug: http://debbugs.gnu.org/cgi/bugreport.cgi?bug=16520
committer: Stefan Monnier <address@hidden>
branch nick: trunk
timestamp: Thu 2014-01-23 10:01:41 -0500
message:
  * lisp/emacs-lisp/cl-macs.el: Improve type->predicate mapping.
  (cl--macroexp-fboundp): New function.
  (cl--make-type-test): Use it.
modified:
  lisp/ChangeLog                 changelog-20091113204419-o5vbwnq5f7feedwu-1432
  lisp/emacs-lisp/cl-macs.el     clmacs.el-20091113204419-o5vbwnq5f7feedwu-612

=== modified file 'lisp/ChangeLog'
--- a/lisp/ChangeLog    2014-01-23 07:53:56 +0000
+++ b/lisp/ChangeLog    2014-01-23 15:01:41 +0000
@@ -1,3 +1,9 @@
+2014-01-23  Stefan Monnier  <address@hidden>
+
+       * 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  <address@hidden>
 
        * emacs-lisp/lisp-mode.el (eval-print-last-sexp, eval-last-sexp):

=== modified file 'lisp/emacs-lisp/cl-macs.el'
--- a/lisp/emacs-lisp/cl-macs.el        2014-01-01 07:43:34 +0000
+++ b/lisp/emacs-lisp/cl-macs.el        2014-01-23 15:01:41 +0000
@@ -2588,6 +2588,17 @@
      (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 @@
            (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))))