diff options
Diffstat (limited to 'lisp/emacs-lisp/cl-macs.el')
| -rw-r--r-- | lisp/emacs-lisp/cl-macs.el | 65 |
1 files changed, 27 insertions, 38 deletions
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index fa6a4bc3a72..69f2792f4bd 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -74,19 +74,8 @@ ;; `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 @@ -503,7 +492,7 @@ its argument list allows full Common Lisp conventions." (while (and (eq (car args) '&aux) (pop args)) (while (and args (not (memq (car args) cl--lambda-list-keywords))) (if (consp (car args)) - (if (and cl--bind-enquote (cadar args)) + (if (and cl--bind-enquote (cl-cadar args)) (cl--do-arglist (caar args) `',(cadr (pop args))) (cl--do-arglist (caar args) (cadr (pop args)))) @@ -587,7 +576,7 @@ its argument list allows full Common Lisp conventions." (if (eq ?_ (aref name 0)) (setq name (substring name 1))) (intern (format ":%s" name))))) - (varg (if (consp (car arg)) (cadar arg) (car arg))) + (varg (if (consp (car arg)) (cl-cadar arg) (car arg))) (def (if (cdr arg) (cadr arg) ;; The ordering between those two or clauses is ;; irrelevant, since in practice only one of the two @@ -1191,10 +1180,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 (caddr cl--loop-args) + (memq (nth 2 cl--loop-args) '(downto above)))) (excl (or (memq (car cl--loop-args) '(above below)) - (memq (caddr cl--loop-args) + (memq (nth 2 cl--loop-args) '(above below)))) (start (and (memq (car cl--loop-args) '(from upfrom downfrom)) @@ -1294,7 +1283,7 @@ For more details, see Info node `(cl)Loop Facility'. (temp-idx (if (eq (car cl--loop-args) 'using) (if (and (= (length (cadr cl--loop-args)) 2) - (eq (caadr cl--loop-args) 'index)) + (eq (cl-caadr cl--loop-args) 'index)) (cadr (cl--pop2 cl--loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-idx--")))) @@ -1326,8 +1315,8 @@ For more details, see Info node `(cl)Loop Facility'. (other (if (eq (car cl--loop-args) 'using) (if (and (= (length (cadr cl--loop-args)) 2) - (memq (caadr cl--loop-args) hash-types) - (not (eq (caadr cl--loop-args) word))) + (memq (cl-caadr cl--loop-args) hash-types) + (not (eq (cl-caadr cl--loop-args) word))) (cadr (cl--pop2 cl--loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-var--")))) @@ -1389,8 +1378,8 @@ For more details, see Info node `(cl)Loop Facility'. (other (if (eq (car cl--loop-args) 'using) (if (and (= (length (cadr cl--loop-args)) 2) - (memq (caadr cl--loop-args) key-types) - (not (eq (caadr cl--loop-args) word))) + (memq (cl-caadr cl--loop-args) key-types) + (not (eq (cl-caadr cl--loop-args) word))) (cadr (cl--pop2 cl--loop-args)) (error "Bad `using' clause")) (make-symbol "--cl-var--")))) @@ -1614,7 +1603,7 @@ If BODY is `setq', then use SPECS for assignments rather than for bindings." (let ((temps nil) (new nil)) (when par (let ((p specs)) - (while (and p (or (symbolp (car-safe (car p))) (null (cadar p)))) + (while (and p (or (symbolp (car-safe (car p))) (null (cl-cadar p)))) (setq p (cdr p))) (when p (setq par nil) @@ -1689,7 +1678,7 @@ such that COMBO is equivalent to (and . CLAUSES)." (setq clauses (cons (nconc (butlast (car clauses)) (if (eq (car-safe (cadr clauses)) 'progn) - (cdadr clauses) + (cl-cdadr clauses) (list (cadr clauses)))) (cddr clauses))) ;; A final (progn ,@A t) is moved outside of the `and'. @@ -1831,7 +1820,7 @@ from OBARRAY. (let (,(car spec)) (mapatoms #'(lambda (,(car spec)) ,@body) ,@(and (cadr spec) (list (cadr spec)))) - ,(caddr spec)))) + ,(nth 2 spec)))) ;;;###autoload (defmacro cl-do-all-symbols (spec &rest body) @@ -2108,9 +2097,9 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). ;; FIXME: For N bindings, this will traverse `body' N times! (macroexpand-all (macroexp-progn body) (cons (list (symbol-name (caar bindings)) - (cadar bindings)) + (cl-cadar bindings)) macroexpand-all-environment)))) - (if (or (null (cdar bindings)) (cddar bindings)) + (if (or (null (cdar bindings)) (cl-cddar bindings)) (macroexp--warn-and-return (format "Malformed `cl-symbol-macrolet' binding: %S" (car bindings)) @@ -2219,7 +2208,7 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C). ((and (eq (car-safe spec) 'warn) (boundp 'byte-compile-warnings)) (while (setq spec (cdr spec)) (if (consp (car spec)) - (if (eq (cadar spec) 0) + (if (eq (cl-cadar spec) 0) (byte-compile-disable-warning (caar spec)) (byte-compile-enable-warning (caar spec))))))) nil) @@ -2663,9 +2652,9 @@ non-nil value, that slot cannot be set via `setf'. (t `(and (consp cl-x) (memq (nth ,pos cl-x) ,tag-symbol)))))) pred-check (and pred-form (> safety 0) - (if (and (eq (caadr pred-form) 'vectorp) + (if (and (eq (cl-caadr pred-form) 'vectorp) (= safety 1)) - (cons 'and (cdddr pred-form)) + (cons 'and (cl-cdddr pred-form)) `(,predicate cl-x)))) (let ((pos 0) (descp descs)) (while descp @@ -3093,14 +3082,14 @@ macro that returns its `&whole' argument." cl-fifth cl-sixth cl-seventh cl-eighth cl-ninth cl-tenth cl-rest cl-endp cl-plusp cl-minusp - caaar caadr cadar - caddr cdaar cdadr - cddar cdddr caaaar - caaadr caadar caaddr - cadaar cadadr caddar - cadddr cdaaar cdaadr - cdadar cdaddr cddaar - cddadr cdddar cddddr)) + cl-caaar cl-caadr cl-cadar + cl-caddr cl-cdaar cl-cdadr + cl-cddar cl-cdddr cl-caaaar + cl-caaadr cl-caadar cl-caaddr + cl-cadaar cl-cadadr cl-caddar + cl-cadddr cl-cdaaar cl-cdaadr + cl-cdadar cl-cdaddr cl-cddaar + cl-cddadr cl-cdddar cl-cddddr)) (put y 'side-effect-free t)) ;;; Things that are inline. |