diff options
Diffstat (limited to 'lisp/emacs-lisp/cl-macs.el')
| -rw-r--r-- | lisp/emacs-lisp/cl-macs.el | 83 |
1 files changed, 52 insertions, 31 deletions
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 9a59aa0c6db..16ac14f8fe9 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -58,6 +58,33 @@ ;;; Initialization. +;; Place compiler macros at the beginning, otherwise uses of the corresponding +;; functions can lead to recursive-loads that prevent the calls from +;; being optimized. + +;;;###autoload +(defun cl--compiler-macro-list* (_form arg &rest others) + (let* ((args (reverse (cons arg others))) + (form (car args))) + (while (setq args (cdr args)) + (setq form `(cons ,(car args) ,form))) + form)) + +;;;###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))) + ;;; Some predicates for analyzing Lisp forms. ;; These are used by various ;; macro expanders to optimize the results in certain common cases. @@ -366,9 +393,14 @@ its argument list allows full Common Lisp conventions." (mapcar (lambda (x) (cond ((symbolp x) - (if (eq ?\& (aref (symbol-name x) 0)) - (setq state x) - (make-symbol (upcase (symbol-name x))))) + (let ((first (aref (symbol-name x) 0))) + (if (eq ?\& first) + (setq state x) + ;; Strip a leading underscore, since it only + ;; means that this argument is unused. + (make-symbol (upcase (if (eq ?_ first) + (substring (symbol-name x) 1) + (symbol-name x))))))) ((not (consp x)) x) ((memq state '(nil &rest)) (cl--make-usage-args x)) (t ;(VAR INITFORM SVAR) or ((KEYWORD VAR) INITFORM SVAR). @@ -452,7 +484,13 @@ its argument list allows full Common Lisp conventions." (let ((arg (pop args))) (or (consp arg) (setq arg (list arg))) (let* ((karg (if (consp (car arg)) (caar arg) - (intern (format ":%s" (car arg))))) + (let ((name (symbol-name (car arg)))) + ;; Strip a leading underscore, since it only + ;; means that this argument is unused, but + ;; shouldn't affect the key's name (bug#12367). + (if (eq ?_ (aref name 0)) + (setq name (substring name 1))) + (intern (format ":%s" name))))) (varg (if (consp (car arg)) (cl-cadar arg) (car arg))) (def (if (cdr arg) (cadr arg) (or (car cl--bind-defs) (cadr (assq varg cl--bind-defs))))) @@ -1425,8 +1463,15 @@ Valid clauses are: cl--loop-accum-var)))) (defun cl--loop-build-ands (clauses) + "Return various representations of (and . CLAUSES). +CLAUSES is a list of Elisp expressions, where clauses of the form +\(progn E1 E2 E3 .. t) are the focus of particular optimizations. +The return value has shape (COND BODY COMBO) +such that COMBO is equivalent to (and . CLAUSES)." (let ((ands nil) (body nil)) + ;; Look through `clauses', trying to optimize (progn ,@A t) (progn ,@B) ,@C + ;; into (progn ,@A ,@B) ,@C. (while clauses (if (and (eq (car-safe (car clauses)) 'progn) (eq (car (last (car clauses))) t)) @@ -1437,6 +1482,7 @@ Valid clauses are: (cl-cdadr clauses) (list (cadr clauses)))) (cddr clauses))) + ;; A final (progn ,@A t) is moved outside of the `and'. (setq body (cdr (butlast (pop clauses))))) (push (pop clauses) ands))) (setq ands (or (nreverse ands) (list t))) @@ -1905,8 +1951,6 @@ See Info node `(cl)Declarations' for details." (cl-do-proclaim (pop specs) nil))) nil) - - ;;; The standard modify macros. ;; `setf' is now part of core Elisp, defined in gv.el. @@ -1929,7 +1973,7 @@ before assigning any PLACEs to the corresponding values. (or p (error "Odd number of arguments to cl-psetf")) (pop p)) (if simple - `(progn (setf ,@args) nil) + `(progn (setq ,@args) nil) (setq args (reverse args)) (let ((expr `(setf ,(cadr args) ,(car args)))) (while (setq args (cddr args)) @@ -2119,7 +2163,7 @@ one keyword is supported, `:read-only'. If this has a non-nil value, that slot cannot be set via `setf'. \(fn NAME SLOTS...)" - (declare (doc-string 2) + (declare (doc-string 2) (indent 1) (debug (&define ;Makes top-level form not be wrapped. [&or symbolp @@ -2597,14 +2641,6 @@ surrounded by (cl-block NAME ...). `(if (cl-member ,a ,list ,@keys) ,list (cons ,a ,list)) form)) -;;;###autoload -(defun cl--compiler-macro-list* (_form arg &rest others) - (let* ((args (reverse (cons arg others))) - (form (car args))) - (while (setq args (cdr args)) - (setq form `(cons ,(car args) ,form))) - form)) - (defun cl--compiler-macro-get (_form sym prop &optional def) (if def `(cl-getf (symbol-plist ,sym) ,prop ,def) @@ -2616,21 +2652,6 @@ surrounded by (cl-block NAME ...). (cl--make-type-test temp (cl--const-expr-val type))) form)) -;;;###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))) - (dolist (y '(cl-first cl-second cl-third cl-fourth cl-fifth cl-sixth cl-seventh cl-eighth cl-ninth cl-tenth |