From d4f0427be7fc035f0c3c0d63bb4707277fdc347e Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 23 Jan 2014 10:01:41 -0500 Subject: [PATCH] * lisp/emacs-lisp/cl-macs.el: Improve type->predicate mapping. (cl--macroexp-fboundp): New function. (cl--make-type-test): Use it. Fixes: debbugs:16520 --- lisp/ChangeLog | 6 ++++++ lisp/emacs-lisp/cl-macs.el | 19 +++++++++++++++++-- 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 + + * 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 * 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)))) -- 2.39.2