procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

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

Fixes: debbugs:16520
This commit is contained in:
Stefan Monnier 2014-01-23 10:01:41 -05:00
parent 565935c89f
commit d4f0427be7
2 changed files with 23 additions and 2 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
lisp/ChangeLog
View file

@ -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):

19
lisp/emacs-lisp/cl-macs.el
View file

@ -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))))