diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/cl-loaddefs.el | 28 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-macs.el | 56 | ||||
| -rw-r--r-- | lisp/emacs-lisp/macroexp.el | 110 | ||||
| -rw-r--r-- | lisp/emacs-lisp/pcase.el | 2 |
4 files changed, 148 insertions, 48 deletions
diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index 470ca17d3a0..7d70d22c9cd 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -249,8 +249,7 @@ Remove from SYMBOL's plist the property PROPNAME and its value. ;;;*** -;;;### (autoloads (cl--compiler-macro-cXXr cl--compiler-macro-list* -;;;;;; cl--compiler-macro-adjoin cl-defsubst cl-compiler-macroexpand +;;;### (autoloads (cl--compiler-macro-adjoin cl-defsubst cl-compiler-macroexpand ;;;;;; cl-define-compiler-macro cl-assert cl-check-type cl-typep ;;;;;; cl-deftype cl-defstruct cl-callf2 cl-callf cl-letf* cl-letf ;;;;;; cl-rotatef cl-shiftf cl-remf cl-psetf cl-declare cl-the cl-locally @@ -260,9 +259,20 @@ Remove from SYMBOL's plist the property PROPNAME and its value. ;;;;;; cl-do cl-loop cl-return-from cl-return cl-block cl-etypecase ;;;;;; cl-typecase cl-ecase cl-case cl-load-time-value cl-eval-when ;;;;;; cl-destructuring-bind cl-function cl-defmacro cl-defun cl-gentemp -;;;;;; cl-gensym) "cl-macs" "cl-macs.el" "9676d5517e8b9246c09fe78984c68bef") +;;;;;; cl-gensym cl--compiler-macro-cXXr cl--compiler-macro-list*) +;;;;;; "cl-macs" "cl-macs.el" "e09b4be5072a8b52d40af6e073876e76") ;;; Generated autoloads from cl-macs.el +(autoload 'cl--compiler-macro-list* "cl-macs" "\ + + +\(fn FORM ARG &rest OTHERS)" nil nil) + +(autoload 'cl--compiler-macro-cXXr "cl-macs" "\ + + +\(fn FORM X)" nil nil) + (autoload 'cl-gensym "cl-macs" "\ Generate a new uninterned symbol. The name is made by appending a number to PREFIX, default \"G\". @@ -659,6 +669,8 @@ value, that slot cannot be set via `setf'. (put 'cl-defstruct 'doc-string-elt '2) +(put 'cl-defstruct 'lisp-indent-function '1) + (autoload 'cl-deftype "cl-macs" "\ Define NAME as a new data type. The type name can then be used in `cl-typecase', `cl-check-type', etc. @@ -722,16 +734,6 @@ surrounded by (cl-block NAME ...). \(fn FORM A LIST &rest KEYS)" nil nil) -(autoload 'cl--compiler-macro-list* "cl-macs" "\ - - -\(fn FORM ARG &rest OTHERS)" nil nil) - -(autoload 'cl--compiler-macro-cXXr "cl-macs" "\ - - -\(fn FORM X)" nil nil) - ;;;*** ;;;### (autoloads (cl-tree-equal cl-nsublis cl-sublis cl-nsubst-if-not diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 9a59aa0c6db..aba412cc8f5 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. @@ -1905,8 +1932,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 +1954,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 +2144,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 +2622,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 +2633,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 diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 70eab149837..394225d697e 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -100,6 +100,17 @@ each clause." (error (message "Compiler-macro error for %S: %S" (car form) err) form))) +(defun macroexp--eval-if-compile (&rest _forms) + "Pseudo function used internally by macroexp to delay warnings. +The purpose is to delay warnings to bytecomp.el, so they can use things +like `byte-compile-log-warning' to get better file-and-line-number data +and also to avoid outputting the warning during normal execution." + nil) +(put 'macroexp--eval-if-compile 'byte-compile + (lambda (form) + (mapc (lambda (x) (funcall (eval x))) (cdr form)) + (byte-compile-constant nil))) + (defun macroexp--expand-all (form) "Expand all macros in FORM. This is an internal version of `macroexpand-all'. @@ -112,14 +123,17 @@ Assumes the caller has bound `macroexpand-all-environment'." (macroexpand (macroexp--all-forms form 1) macroexpand-all-environment) ;; Normal form; get its expansion, and then expand arguments. - (let ((new-form (macroexpand form macroexpand-all-environment))) - (when (and (not (eq form new-form)) ;It was a macro call. - (car-safe form) - (symbolp (car form)) - (get (car form) 'byte-obsolete-info) - (fboundp 'byte-compile-warn-obsolete)) - (byte-compile-warn-obsolete (car form))) - (setq form new-form)) + (let ((new-form + (macroexpand form macroexpand-all-environment))) + (setq form + (if (and (not (eq form new-form)) ;It was a macro call. + (car-safe form) + (symbolp (car form)) + (get (car form) 'byte-obsolete-info)) + `(progn (macroexp--eval-if-compile + (lambda () (byte-compile-warn-obsolete ',(car form)))) + ,new-form) + new-form))) (pcase form (`(cond . ,clauses) (macroexp--cons 'cond (macroexp--all-clauses clauses) form)) @@ -323,6 +337,86 @@ symbol itself." "Return non-nil if EXP can be copied without extra cost." (or (symbolp exp) (macroexp-const-p exp))) +;;; Load-time macro-expansion. + +;; Because macro-expansion used to be more lazy, eager macro-expansion +;; tends to bump into previously harmless/unnoticeable cyclic-dependencies. +;; So, we have to delay macro-expansion like we used to when we detect +;; such a cycle, and we also want to help coders resolve those cycles (since +;; they can be non-obvious) by providing a usefully trimmed backtrace +;; (hopefully) highlighting the problem. + +(defun macroexp--backtrace () + "Return the Elisp backtrace, more recent frames first." + (let ((bt ()) + (i 0)) + (while + (let ((frame (backtrace-frame i))) + (when frame + (push frame bt) + (setq i (1+ i))))) + (nreverse bt))) + +(defun macroexp--trim-backtrace-frame (frame) + (pcase frame + (`(,_ macroexpand (,head . ,_) . ,_) `(macroexpand (,head …))) + (`(,_ internal-macroexpand-for-load (,head ,second . ,_) . ,_) + (if (or (symbolp second) + (and (eq 'quote (car-safe second)) + (symbolp (cadr second)))) + `(macroexpand-all (,head ,second …)) + '(macroexpand-all …))) + (`(,_ load-with-code-conversion ,name . ,_) + `(load ,(file-name-nondirectory name))))) + +(defvar macroexp--pending-eager-loads nil + "Stack of files currently undergoing eager macro-expansion.") + +(defun internal-macroexpand-for-load (form) + ;; Called from the eager-macroexpansion in readevalloop. + (cond + ;; Don't repeat the same warning for every top-level element. + ((eq 'skip (car macroexp--pending-eager-loads)) form) + ;; If we detect a cycle, skip macro-expansion for now, and output a warning + ;; with a trimmed backtrace. + ((and load-file-name (member load-file-name macroexp--pending-eager-loads)) + (let* ((bt (delq nil + (mapcar #'macroexp--trim-backtrace-frame + (macroexp--backtrace)))) + (elem `(load ,(file-name-nondirectory load-file-name))) + (tail (member elem (cdr (member elem bt))))) + (if tail (setcdr tail (list '…))) + (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt))) + (message "Warning: Eager macro-expansion skipped due to cycle:\n %s" + (mapconcat #'prin1-to-string (nreverse bt) " => ")) + (push 'skip macroexp--pending-eager-loads) + form)) + (t + (condition-case err + (let ((macroexp--pending-eager-loads + (cons load-file-name macroexp--pending-eager-loads))) + (macroexpand-all form)) + (error + ;; Hopefully this shouldn't happen thanks to the cycle detection, + ;; but in case it does happen, let's catch the error and give the + ;; code a chance to macro-expand later. + (message "Eager macro-expansion failure: %S" err) + form))))) + +;; ¡¡¡ Big Ugly Hack !!! +;; src/bootstrap-emacs is mostly used to compile .el files, so it needs +;; macroexp, bytecomp, cconv, and byte-opt to be fast. Generally this is done +;; by compiling those files first, but this only makes a difference if those +;; files are not preloaded. But macroexp.el is preloaded so we reload it if +;; the current version is interpreted and there's a compiled version available. +(eval-when-compile + (add-hook 'emacs-startup-hook + (lambda () + (and (not (byte-code-function-p + (symbol-function 'macroexpand-all))) + (locate-library "macroexp.elc") + (load "macroexp.elc"))))) + (provide 'macroexp) ;;; macroexp.el ends here diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 4aeed7e4d0e..09e47b69b91 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -60,6 +60,8 @@ ;; is in a loop, the repeated macro-expansion becomes terribly costly, so we ;; memoize previous macro expansions to try and avoid recomputing them ;; over and over again. +;; FIXME: Now that macroexpansion is also performed when loading an interpreted +;; file, this is not a real problem any more. (defconst pcase--memoize (make-hash-table :weakness 'key :test 'eq)) ;; (defconst pcase--memoize-1 (make-hash-table :test 'eq)) ;; (defconst pcase--memoize-2 (make-hash-table :weakness 'key :test 'equal)) |