diff options
| author | Alan Mackenzie | 2022-02-24 17:30:39 +0000 |
|---|---|---|
| committer | Alan Mackenzie | 2022-02-24 17:30:39 +0000 |
| commit | 6092ee1c3ff503fbe8087e13b7eae2f904c4af3b (patch) | |
| tree | 1486437e4446aadebfb6a6b7ec06299f9ba96c9e | |
| parent | 2db149539bc7f9720856f1d17f0e7fa9bf735ea1 (diff) | |
| download | emacs-6092ee1c3ff503fbe8087e13b7eae2f904c4af3b.tar.gz emacs-6092ee1c3ff503fbe8087e13b7eae2f904c4af3b.zip | |
Amend byte-run-strip-symbol-positions so that an unexec build builds
This fixes bug #54098.
* lisp/emacs-lisp/byte-run.el (byte-run--strip-list)
(byte-run--strip-vector/record): New functions. These alter a list or
vector/record structure only where a symbol with position gets replaced by a
bare symbol.
(byte-run-strip-symbol-positions): Reformulate to use the two new functions.
(function-put): No longer strip positions from the second and third arguments.
* lisp/emacs-lisp/bytecomp.el (byte-compile-out): Remove the senseless
"stripping" of putative symbol positions from OPERAND, which is nil or a
number.
| -rw-r--r-- | lisp/emacs-lisp/byte-run.el | 98 | ||||
| -rw-r--r-- | lisp/emacs-lisp/bytecomp.el | 3 |
2 files changed, 57 insertions, 44 deletions
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index c542c550169..d7a2d8cecaf 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el | |||
| @@ -37,53 +37,69 @@ the corresponding new element of the same type. | |||
| 37 | 37 | ||
| 38 | The purpose of this is to detect circular structures.") | 38 | The purpose of this is to detect circular structures.") |
| 39 | 39 | ||
| 40 | (defalias 'byte-run--strip-s-p-1 | 40 | (defalias 'byte-run--strip-list |
| 41 | #'(lambda (arg) | 41 | #'(lambda (arg) |
| 42 | "Strip all positions from symbols in ARG, modifying ARG. | 42 | "Strip the positions from symbols with position in the list ARG. |
| 43 | Return the modified ARG." | 43 | This is done by destructively modifying ARG. Return ARG." |
| 44 | (let ((a arg)) | ||
| 45 | (while | ||
| 46 | (and | ||
| 47 | (not (gethash a byte-run--ssp-seen)) | ||
| 48 | (progn | ||
| 49 | (puthash a t byte-run--ssp-seen) | ||
| 50 | (cond | ||
| 51 | ((symbol-with-pos-p (car a)) | ||
| 52 | (setcar a (bare-symbol (car a)))) | ||
| 53 | ((consp (car a)) | ||
| 54 | (byte-run--strip-list (car a))) | ||
| 55 | ((or (vectorp (car a)) (recordp (car a))) | ||
| 56 | (byte-run--strip-vector/record (car a)))) | ||
| 57 | (consp (cdr a)))) | ||
| 58 | (setq a (cdr a))) | ||
| 59 | (cond | ||
| 60 | ((symbol-with-pos-p (cdr a)) | ||
| 61 | (setcdr a (bare-symbol (cdr a)))) | ||
| 62 | ((or (vectorp (cdr a)) (recordp (cdr a))) | ||
| 63 | (byte-run--strip-vector/record (cdr a)))) | ||
| 64 | arg))) | ||
| 65 | |||
| 66 | (defalias 'byte-run--strip-vector/record | ||
| 67 | #'(lambda (arg) | ||
| 68 | "Strip the positions from symbols with position in the vector/record ARG. | ||
| 69 | This is done by destructively modifying ARG. Return ARG." | ||
| 70 | (unless (gethash arg byte-run--ssp-seen) | ||
| 71 | (let ((len (length arg)) | ||
| 72 | (i 0) | ||
| 73 | elt) | ||
| 74 | (puthash arg t byte-run--ssp-seen) | ||
| 75 | (while (< i len) | ||
| 76 | (setq elt (aref arg i)) | ||
| 77 | (cond | ||
| 78 | ((symbol-with-pos-p elt) | ||
| 79 | (aset arg i elt)) | ||
| 80 | ((consp elt) | ||
| 81 | (byte-run--strip-list elt)) | ||
| 82 | ((or (vectorp elt) (recordp elt)) | ||
| 83 | (byte-run--strip-vector/record elt)))))) | ||
| 84 | arg)) | ||
| 85 | |||
| 86 | (defalias 'byte-run-strip-symbol-positions | ||
| 87 | #'(lambda (arg) | ||
| 88 | "Strip all positions from symbols in ARG. | ||
| 89 | This modifies destructively then returns ARG. | ||
| 90 | |||
| 91 | ARG is any Lisp object, but is usually a list or a vector or a | ||
| 92 | record, containing symbols with position." | ||
| 93 | (setq byte-run--ssp-seen (make-hash-table :test 'eq)) | ||
| 44 | (cond | 94 | (cond |
| 45 | ((symbol-with-pos-p arg) | 95 | ((symbol-with-pos-p arg) |
| 46 | (bare-symbol arg)) | 96 | (bare-symbol arg)) |
| 47 | |||
| 48 | ((consp arg) | 97 | ((consp arg) |
| 49 | (let* ((hash (gethash arg byte-run--ssp-seen))) | 98 | (byte-run--strip-list arg)) |
| 50 | (if hash ; Already processed this node. | ||
| 51 | arg | ||
| 52 | (let ((a arg) new) | ||
| 53 | (while | ||
| 54 | (progn | ||
| 55 | (puthash a t byte-run--ssp-seen) | ||
| 56 | (setq new (byte-run--strip-s-p-1 (car a))) | ||
| 57 | (setcar a new) | ||
| 58 | (and (consp (cdr a)) | ||
| 59 | (not | ||
| 60 | (setq hash (gethash (cdr a) byte-run--ssp-seen))))) | ||
| 61 | (setq a (cdr a))) | ||
| 62 | (setq new (byte-run--strip-s-p-1 (cdr a))) | ||
| 63 | (setcdr a new) | ||
| 64 | arg)))) | ||
| 65 | |||
| 66 | ((or (vectorp arg) (recordp arg)) | 99 | ((or (vectorp arg) (recordp arg)) |
| 67 | (let ((hash (gethash arg byte-run--ssp-seen))) | 100 | (byte-run--strip-vector/record arg)) |
| 68 | (if hash | ||
| 69 | arg | ||
| 70 | (let* ((len (length arg)) | ||
| 71 | (i 0) | ||
| 72 | new) | ||
| 73 | (puthash arg t byte-run--ssp-seen) | ||
| 74 | (while (< i len) | ||
| 75 | (setq new (byte-run--strip-s-p-1 (aref arg i))) | ||
| 76 | (aset arg i new) | ||
| 77 | (setq i (1+ i))) | ||
| 78 | arg)))) | ||
| 79 | |||
| 80 | (t arg)))) | 101 | (t arg)))) |
| 81 | 102 | ||
| 82 | (defalias 'byte-run-strip-symbol-positions | ||
| 83 | #'(lambda (arg) | ||
| 84 | (setq byte-run--ssp-seen (make-hash-table :test 'eq)) | ||
| 85 | (byte-run--strip-s-p-1 arg))) | ||
| 86 | |||
| 87 | (defalias 'function-put | 103 | (defalias 'function-put |
| 88 | ;; We don't want people to just use `put' because we can't conveniently | 104 | ;; We don't want people to just use `put' because we can't conveniently |
| 89 | ;; hook into `put' to remap old properties to new ones. But for now, there's | 105 | ;; hook into `put' to remap old properties to new ones. But for now, there's |
| @@ -92,9 +108,7 @@ Return the modified ARG." | |||
| 92 | "Set FUNCTION's property PROP to VALUE. | 108 | "Set FUNCTION's property PROP to VALUE. |
| 93 | The namespace for PROP is shared with symbols. | 109 | The namespace for PROP is shared with symbols. |
| 94 | So far, FUNCTION can only be a symbol, not a lambda expression." | 110 | So far, FUNCTION can only be a symbol, not a lambda expression." |
| 95 | (put (bare-symbol function) | 111 | (put (bare-symbol function) prop value))) |
| 96 | (byte-run-strip-symbol-positions prop) | ||
| 97 | (byte-run-strip-symbol-positions value)))) | ||
| 98 | (function-put 'defmacro 'doc-string-elt 3) | 112 | (function-put 'defmacro 'doc-string-elt 3) |
| 99 | (function-put 'defmacro 'lisp-indent-function 2) | 113 | (function-put 'defmacro 'lisp-indent-function 2) |
| 100 | 114 | ||
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index c59bb292f8f..6f83429dd4b 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el | |||
| @@ -5099,7 +5099,7 @@ binding slots have been popped." | |||
| 5099 | OP and OPERAND are as passed to `byte-compile-out'." | 5099 | OP and OPERAND are as passed to `byte-compile-out'." |
| 5100 | (if (memq op '(byte-call byte-discardN byte-discardN-preserve-tos)) | 5100 | (if (memq op '(byte-call byte-discardN byte-discardN-preserve-tos)) |
| 5101 | ;; For calls, OPERAND is the number of args, so we pop OPERAND + 1 | 5101 | ;; For calls, OPERAND is the number of args, so we pop OPERAND + 1 |
| 5102 | ;; elements, and the push the result, for a total of -OPERAND. | 5102 | ;; elements, and then push the result, for a total of -OPERAND. |
| 5103 | ;; For discardN*, of course, we just pop OPERAND elements. | 5103 | ;; For discardN*, of course, we just pop OPERAND elements. |
| 5104 | (- operand) | 5104 | (- operand) |
| 5105 | (or (aref byte-stack+-info (symbol-value op)) | 5105 | (or (aref byte-stack+-info (symbol-value op)) |
| @@ -5109,7 +5109,6 @@ OP and OPERAND are as passed to `byte-compile-out'." | |||
| 5109 | (- 1 operand)))) | 5109 | (- 1 operand)))) |
| 5110 | 5110 | ||
| 5111 | (defun byte-compile-out (op &optional operand) | 5111 | (defun byte-compile-out (op &optional operand) |
| 5112 | (setq operand (byte-run-strip-symbol-positions operand)) | ||
| 5113 | (push (cons op operand) byte-compile-output) | 5112 | (push (cons op operand) byte-compile-output) |
| 5114 | (if (eq op 'byte-return) | 5113 | (if (eq op 'byte-return) |
| 5115 | ;; This is actually an unnecessary case, because there should be no | 5114 | ;; This is actually an unnecessary case, because there should be no |