master 0d6c513: * lisp/emacs-lisp/cl-macs.el: More care with `eval` and with `cl-typep`

[Stefan Monnier]

branch: master
commit 0d6c51320d8066db867aae0e623d9731c69121ed
Author: Stefan Monnier <address@hidden>
Commit: Stefan Monnier <address@hidden>

    * lisp/emacs-lisp/cl-macs.el: More care with `eval` and with `cl-typep`
    
    (cl-eval-when, cl--compile-time-too, cl-load-time-value):
    Obey lexical-binding.
    (cl-check-type): Prefer the predicate rather than the type in the
    error signal when it's easy to do (as is done outside of CL).
    (cl-deftype-satisfies): Add definitions for standard types.
---
 lisp/emacs-lisp/cl-macs.el | 57 ++++++++++++++++++++++++++++++----------------
 1 file changed, 37 insertions(+), 20 deletions(-)

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index ef3bc85..954731b 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -75,7 +75,7 @@
 ;; one, you may want to amend the other, too.
 ;;;###autoload
 (define-obsolete-function-alias 'cl--compiler-macro-cXXr
-  'internal--compiler-macro-cXXr "25.1")
+  #'internal--compiler-macro-cXXr "25.1")
 
 ;;; Some predicates for analyzing Lisp forms.
 ;; These are used by various
@@ -714,9 +714,9 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or 
at non-top-level.
       (let ((comp (or (memq 'compile when) (memq :compile-toplevel when)))
            (cl--not-toplevel t))
        (if (or (memq 'load when) (memq :load-toplevel when))
-           (if comp (cons 'progn (mapcar 'cl--compile-time-too body))
+           (if comp (cons 'progn (mapcar #'cl--compile-time-too body))
              `(if nil nil ,@body))
-         (progn (if comp (eval (cons 'progn body))) nil)))
+         (progn (if comp (eval (cons 'progn body) lexical-binding)) nil)))
     (and (or (memq 'eval when) (memq :execute when))
         (cons 'progn body))))
 
@@ -725,13 +725,13 @@ If `eval' is in WHEN, BODY is evaluated when interpreted 
or at non-top-level.
       (setq form (macroexpand
                  form (cons '(cl-eval-when) byte-compile-macro-environment))))
   (cond ((eq (car-safe form) 'progn)
-        (cons 'progn (mapcar 'cl--compile-time-too (cdr form))))
+        (cons 'progn (mapcar #'cl--compile-time-too (cdr form))))
        ((eq (car-safe form) 'cl-eval-when)
         (let ((when (nth 1 form)))
           (if (or (memq 'eval when) (memq :execute when))
               `(cl-eval-when (compile ,@when) ,@(cddr form))
             form)))
-       (t (eval form) form)))
+       (t (eval form lexical-binding) form)))
 
 ;;;###autoload
 (defmacro cl-load-time-value (form &optional _read-only)
@@ -757,7 +757,7 @@ The result of the body appears to the compiler as a quoted 
constant."
           ;; temp is set before we use it.
           (print set byte-compile--outbuffer))
        temp)
-    `',(eval form)))
+    `',(eval form lexical-binding)))
 
 
 ;;; Conditional control structures.
@@ -1495,8 +1495,8 @@ For more details, see Info node `(cl)Loop Facility'.
          (pop cl--loop-args))
        (if (and ands loop-for-bindings)
            (push (nreverse loop-for-bindings) cl--loop-bindings)
-         (setq cl--loop-bindings (nconc (mapcar 'list loop-for-bindings)
-                                    cl--loop-bindings)))
+         (setq cl--loop-bindings (nconc (mapcar #'list loop-for-bindings)
+                                        cl--loop-bindings)))
        (if loop-for-sets
            (push `(progn
                      ,(cl--loop-let (nreverse loop-for-sets) 'setq ands)
@@ -1504,7 +1504,7 @@ For more details, see Info node `(cl)Loop Facility'.
                   cl--loop-body))
        (when loop-for-steps
          (push (cons (if ands 'cl-psetq 'setq)
-                     (apply 'append (nreverse loop-for-steps)))
+                     (apply #'append (nreverse loop-for-steps)))
                cl--loop-steps))))
 
      ((eq word 'repeat)
@@ -1697,7 +1697,7 @@ If BODY is `setq', then use SPECS for assignments rather 
than for bindings."
           (push binding new))))
     (if (eq body 'setq)
        (let ((set (cons (if par 'cl-psetq 'setq)
-                         (apply 'nconc (nreverse new)))))
+                         (apply #'nconc (nreverse new)))))
          (if temps `(let* ,(nreverse temps) ,set) set))
       `(,(if par 'let 'let*)
         ,(nconc (nreverse temps) (nreverse new)) ,@body))))
@@ -1823,7 +1823,7 @@ For more details, see `cl-do*' description in Info node 
`(cl) Iteration'.
             (and sets
                  (list (cons (if (or star (not (cdr sets)))
                                  'setq 'cl-psetq)
-                             (apply 'append sets))))))
+                             (apply #'append sets))))))
       ,@(or (cdr endtest) '(nil)))))
 
 ;;;###autoload
@@ -2468,7 +2468,7 @@ Each PLACE may be a symbol, or any generalized variable 
allowed by `setf'.
 
 \(fn PLACE...)"
   (declare (debug (&rest place)))
-  (if (not (memq nil (mapcar 'symbolp args)))
+  (if (not (memq nil (mapcar #'symbolp args)))
       (and (cdr args)
           (let ((sets nil)
                 (first (car args)))
@@ -3128,13 +3128,27 @@ Of course, we really can't know that for sure, so it's 
just a heuristic."
            (or (cdr (assq sym byte-compile-function-environment))
                (cdr (assq sym byte-compile-macro-environment))))))
 
-(put 'null 'cl-deftype-satisfies #'null)
-(put 'atom 'cl-deftype-satisfies #'atom)
-(put 'real 'cl-deftype-satisfies #'numberp)
-(put 'fixnum 'cl-deftype-satisfies #'integerp)
-(put 'base-char 'cl-deftype-satisfies #'characterp)
-(put 'character 'cl-deftype-satisfies #'natnump)
-
+(pcase-dolist (`(,type . ,pred)
+               '((null         . null)
+                 (atom         . atom)
+                 (real         . numberp)
+                 (fixnum       . integerp)
+                 (base-char    . characterp)
+                 (character    . natnump)
+                 ;; "Obvious" mappings.
+                 (string       . stringp)
+                 (list         . listp)
+                 (symbol       . symbolp)
+                 (function     . functionp)
+                 (integer      . integerp)
+                 (float                . floatp)
+                 (boolean      . booleanp)
+                 (vector       . vectorp)
+                 (array                . arrayp)
+                 ;; FIXME: Do we really want to consider this a type?
+                 (integer-or-marker . integer-or-marker-p)
+                 ))
+  (put type 'cl-deftype-satisfies pred))
 
 ;;;###autoload
 (define-inline cl-typep (val type)
@@ -3203,7 +3217,10 @@ STRING is an optional description of the desired type."
        (macroexp-let2 macroexp-copyable-p temp form
          `(progn (or (cl-typep ,temp ',type)
                      (signal 'wrong-type-argument
-                             (list ,(or string `',type) ,temp ',form)))
+                             (list ,(or string `',(if (eq 'satisfies
+                                                          (car-safe type))
+                                                      (cadr type) type))
+                                   ,temp ',form)))
                  nil))))
 
 ;;;###autoload