Un-revert changes mistakenly dropped by f9fabb2b

[gnu-emacs] / lisp / emacs-lisp / cl-macs.el

diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index f8ddc00c3bf90e6e363c04ce2c7e8304990a3393..636c5433a97a577cd7b6c1e11a88117a5ed9038e 100644 (file)
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -70,20 +70,12 @@
       (setq form `(cons ,(car args) ,form)))
     form))
 
+;; Note: `cl--compiler-macro-cXXr' has been copied to
+;; `internal--compiler-macro-cXXr' in subr.el.  If you amend either
+;; one, you may want to amend the other, too.
 ;;;###autoload
-(defun cl--compiler-macro-cXXr (form x)
-  (let* ((head (car form))
-         (n (symbol-name (car form)))
-         (i (- (length n) 2)))
-    (if (not (string-match "c[ad]+r\\'" n))
-        (if (and (fboundp head) (symbolp (symbol-function head)))
-            (cl--compiler-macro-cXXr (cons (symbol-function head) (cdr form))
-                                     x)
-          (error "Compiler macro for cXXr applied to non-cXXr form"))
-      (while (> i (match-beginning 0))
-        (setq x (list (if (eq (aref n i) ?a) 'car 'cdr) x))
-        (setq i (1- i)))
-      x)))
+(define-obsolete-function-alias 'cl--compiler-macro-cXXr
+  'internal--compiler-macro-cXXr "25.1")
 
 ;;; Some predicates for analyzing Lisp forms.
 ;; These are used by various
@@ -302,7 +294,6 @@ FORM is of the form (ARGS . BODY)."
                       ;; apparently harmless computation, so it should not
                       ;; touch the match-data.
                       (save-match-data
-                        (require 'help-fns)
                         (cons (help-add-fundoc-usage
                                (if (stringp (car header)) (pop header))
                                ;; Be careful with make-symbol and (back)quote,
@@ -1188,10 +1179,10 @@ For more details, see Info node `(cl)Loop Facility'.
                (if (memq (car cl--loop-args) '(downto above))
                    (error "Must specify `from' value for downward cl-loop"))
                (let* ((down (or (eq (car cl--loop-args) 'downfrom)
-                                (memq (cl-caddr cl--loop-args)
+                                (memq (nth 2 cl--loop-args)
                                        '(downto above))))
                       (excl (or (memq (car cl--loop-args) '(above below))
-                                (memq (cl-caddr cl--loop-args)
+                                (memq (nth 2 cl--loop-args)
                                        '(above below))))
                       (start (and (memq (car cl--loop-args)
                                          '(from upfrom downfrom))
@@ -1795,7 +1786,8 @@ Labels have lexical scope and dynamic extent."
       (unless (eq 'go (car-safe (car-safe block)))
         (push `(go cl--exit) block))
       (push (nreverse block) blocks))
-    (let ((catch-tag (make-symbol "cl--tagbody-tag")))
+    (let ((catch-tag (make-symbol "cl--tagbody-tag"))
+          (cl--tagbody-alist cl--tagbody-alist))
       (push (cons 'cl--exit catch-tag) cl--tagbody-alist)
       (dolist (block blocks)
         (push (cons (car block) catch-tag) cl--tagbody-alist))
@@ -1828,7 +1820,7 @@ from OBARRAY.
      (let (,(car spec))
        (mapatoms #'(lambda (,(car spec)) ,@body)
                  ,@(and (cadr spec) (list (cadr spec))))
-       ,(cl-caddr spec))))
+       ,(nth 2 spec))))
 
 ;;;###autoload
 (defmacro cl-do-all-symbols (spec &rest body)
@@ -2734,12 +2726,16 @@ non-nil value, that slot cannot be set via `setf'.
                 constrs))
     (while constrs
       (let* ((name (caar constrs))
-            (args (cadr (pop constrs)))
+             (rest (cdr (pop constrs)))
+             (args (car rest))
+             (doc  (cadr rest))
             (anames (cl--arglist-args args))
             (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d)))
                            slots defaults)))
        (push `(cl-defsubst ,name
                    (&cl-defs (nil ,@descs) ,@args)
+                 ,@(if (stringp doc) (list doc)
+                     (if (stringp docstring) (list docstring)))
                  ,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs)))
                        '((declare (side-effect-free t))))
                  (,(or type #'vector) ,@make))
@@ -2788,6 +2784,7 @@ non-nil value, that slot cannot be set via `setf'.
 Elements of FIELDS can be of the form (NAME UPAT) in which case the contents of
 field NAME is matched against UPAT, or they can be of the form NAME which
 is a shorthand for (NAME NAME)."
+  (declare (debug (sexp &rest [&or (sexp pcase-UPAT) sexp])))
   `(and (pred (pcase--flip cl-typep ',type))
         ,@(mapcar
            (lambda (field)