diff options
Diffstat (limited to 'lisp/emacs-lisp/macroexp.el')
| -rw-r--r-- | lisp/emacs-lisp/macroexp.el | 92 |
1 files changed, 85 insertions, 7 deletions
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index b44917f7d56..663856a8fb3 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -32,6 +32,78 @@ ;; macros defined by `defmacro'. (defvar macroexpand-all-environment nil) +(defvar macroexp--ssp-conses-seen nil + "Which conses have been processed in a strip-symbol-positions operation?") +(defvar macroexp--ssp-vectors-seen nil + "Which vectors have been processed in a strip-symbol-positions operation?") +(defvar macroexp--ssp-records-seen nil + "Which records have been processed in a strip-symbol-positions operation?") + +(defun macroexp--strip-s-p-2 (arg) + "Strip all positions from symbols in ARG, destructively modifying ARG. +Return the modified ARG." + (cond + ((symbolp arg) + (bare-symbol arg)) + ((consp arg) + (unless (and macroexp--ssp-conses-seen + (gethash arg macroexp--ssp-conses-seen)) + (if macroexp--ssp-conses-seen + (puthash arg t macroexp--ssp-conses-seen)) + (let ((a arg)) + (while (consp (cdr a)) + (setcar a (macroexp--strip-s-p-2 (car a))) + (setq a (cdr a))) + (setcar a (macroexp--strip-s-p-2 (car a))) + ;; (if (cdr a) + (unless (bare-symbol-p (cdr a)) ; includes (unpositioned) nil. + (setcdr a (macroexp--strip-s-p-2 (cdr a)))))) + arg) + ((vectorp arg) + (unless (and macroexp--ssp-vectors-seen + (gethash arg macroexp--ssp-vectors-seen)) + (if macroexp--ssp-vectors-seen + (puthash arg t macroexp--ssp-vectors-seen)) + (let ((i 0) + (len (length arg))) + (while (< i len) + (aset arg i (macroexp--strip-s-p-2 (aref arg i))) + (setq i (1+ i))))) + arg) + ((recordp arg) + (unless (and macroexp--ssp-records-seen + (gethash arg macroexp--ssp-records-seen)) + (if macroexp--ssp-records-seen + (puthash arg t macroexp--ssp-records-seen)) + (let ((i 0) + (len (length arg))) + (while (< i len) + (aset arg i (macroexp--strip-s-p-2 (aref arg i))) + (setq i (1+ i))))) + arg) + (t arg))) + +(defun byte-compile-strip-s-p-1 (arg) + "Strip all positions from symbols in ARG, destructively modifying ARG. +Return the modified ARG." + (condition-case err + (progn + (setq macroexp--ssp-conses-seen nil) + (setq macroexp--ssp-vectors-seen nil) + (setq macroexp--ssp-records-seen nil) + (macroexp--strip-s-p-2 arg)) + (recursion-error + (dolist (tab '(macroexp--ssp-conses-seen macroexp--ssp-vectors-seen + macroexp--ssp-records-seen)) + (set tab (make-hash-table :test 'eq))) + (macroexp--strip-s-p-2 arg)) + (error (signal (car err) (cdr err))))) + +(defun macroexp-strip-symbol-positions (arg) + "Strip all positions from symbols (recursively) in ARG. Don't modify ARG." + (let ((arg1 (copy-tree arg t))) + (byte-compile-strip-s-p-1 arg1))) + (defun macroexp--cons (car cdr original-cons) "Return ORIGINAL-CONS if the car/cdr of it is `eq' to CAR and CDR, respectively. If not, return (CAR . CDR)." @@ -96,10 +168,11 @@ each clause." (defun macroexp--compiler-macro (handler form) (condition-case-unless-debug err - (apply handler form (cdr form)) + (let ((symbols-with-pos-enabled t)) + (apply handler form (cdr form))) (error - (message "Compiler-macro error for %S: %S" (car form) err) - form))) + (message "Compiler-macro error for %S: Handler: %S\n%S" (car form) handler err) + form))) (defun macroexp--funcall-if-compiled (_form) "Pseudo function used internally by macroexp to delay warnings. @@ -135,20 +208,20 @@ Other uses risk returning non-nil value that point to the wrong file." (defvar macroexp--warned (make-hash-table :test #'equal :weakness 'key)) -(defun macroexp--warn-wrap (msg form category) +(defun macroexp--warn-wrap (arg msg form category) (let ((when-compiled (lambda () (when (if (consp category) (apply #'byte-compile-warning-enabled-p category) (byte-compile-warning-enabled-p category)) - (byte-compile-warn "%s" msg))))) + (byte-compile-warn-x arg "%s" msg))))) `(progn (macroexp--funcall-if-compiled ',when-compiled) ,form))) (define-obsolete-function-alias 'macroexp--warn-and-return #'macroexp-warn-and-return "28.1") -(defun macroexp-warn-and-return (msg form &optional category compile-only) +(defun macroexp-warn-and-return (arg msg form &optional category compile-only) "Return code equivalent to FORM labeled with warning MSG. CATEGORY is the category of the warning, like the categories that can appear in `byte-compile-warnings'. @@ -163,7 +236,7 @@ is executed without being compiled first." ;; macroexpand-all gets right back to macroexpanding `form'. form (puthash form form macroexp--warned) - (macroexp--warn-wrap msg form category))) + (macroexp--warn-wrap arg msg form category))) (t (unless compile-only (message "%sWarning: %s" @@ -219,6 +292,7 @@ is executed without being compiled first." (let* ((fun (car form)) (obsolete (get fun 'byte-obsolete-info))) (macroexp-warn-and-return + fun (macroexp--obsolete-warning fun obsolete (if (symbolp (symbol-function fun)) @@ -274,6 +348,7 @@ is executed without being compiled first." (setq arglist (cdr arglist))) (if values (macroexp-warn-and-return + name (format (if (eq values 'too-few) "attempt to open-code `%s' with too few arguments" "attempt to open-code `%s' with too many arguments") @@ -347,6 +422,7 @@ Assumes the caller has bound `macroexpand-all-environment'." (if (null body) (macroexp-unprogn (macroexp-warn-and-return + fun (format "Empty %s body" fun) nil nil 'compile-only)) (macroexp--all-forms body)) @@ -384,6 +460,7 @@ Assumes the caller has bound `macroexpand-all-environment'." (eq 'lambda (car-safe (cadr arg)))) (setcar (nthcdr funarg form) (macroexp-warn-and-return + (cadr arg) (format "%S quoted with ' rather than with #'" (let ((f (cadr arg))) (if (symbolp f) f `(lambda ,(nth 1 f) ...)))) @@ -704,6 +781,7 @@ test of free variables in the following ways: (defun internal-macroexpand-for-load (form full-p) ;; Called from the eager-macroexpansion in readevalloop. + (setq form (macroexp-strip-symbol-positions form)) (cond ;; Don't repeat the same warning for every top-level element. ((eq 'skip (car macroexp--pending-eager-loads)) form) |