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.
This commit is contained in:
Alan Mackenzie
parent
2db149539b
commit
6092ee1c3f
2 changed files with 58 additions and 45 deletions
|
|
@ -37,52 +37,68 @@ the corresponding new element of the same type.
|
|||
|
||||
The purpose of this is to detect circular structures.")
|
||||
|
||||
(defalias 'byte-run--strip-s-p-1
|
||||
(defalias 'byte-run--strip-list
|
||||
#'(lambda (arg)
|
||||
"Strip all positions from symbols in ARG, modifying ARG.
|
||||
Return the modified ARG."
|
||||
(cond
|
||||
((symbol-with-pos-p arg)
|
||||
(bare-symbol arg))
|
||||
"Strip the positions from symbols with position in the list ARG.
|
||||
This is done by destructively modifying ARG. Return ARG."
|
||||
(let ((a arg))
|
||||
(while
|
||||
(and
|
||||
(not (gethash a byte-run--ssp-seen))
|
||||
(progn
|
||||
(puthash a t byte-run--ssp-seen)
|
||||
(cond
|
||||
((symbol-with-pos-p (car a))
|
||||
(setcar a (bare-symbol (car a))))
|
||||
((consp (car a))
|
||||
(byte-run--strip-list (car a)))
|
||||
((or (vectorp (car a)) (recordp (car a)))
|
||||
(byte-run--strip-vector/record (car a))))
|
||||
(consp (cdr a))))
|
||||
(setq a (cdr a)))
|
||||
(cond
|
||||
((symbol-with-pos-p (cdr a))
|
||||
(setcdr a (bare-symbol (cdr a))))
|
||||
((or (vectorp (cdr a)) (recordp (cdr a)))
|
||||
(byte-run--strip-vector/record (cdr a))))
|
||||
arg)))
|
||||
|
||||
((consp arg)
|
||||
(let* ((hash (gethash arg byte-run--ssp-seen)))
|
||||
(if hash ; Already processed this node.
|
||||
arg
|
||||
(let ((a arg) new)
|
||||
(while
|
||||
(progn
|
||||
(puthash a t byte-run--ssp-seen)
|
||||
(setq new (byte-run--strip-s-p-1 (car a)))
|
||||
(setcar a new)
|
||||
(and (consp (cdr a))
|
||||
(not
|
||||
(setq hash (gethash (cdr a) byte-run--ssp-seen)))))
|
||||
(setq a (cdr a)))
|
||||
(setq new (byte-run--strip-s-p-1 (cdr a)))
|
||||
(setcdr a new)
|
||||
arg))))
|
||||
|
||||
((or (vectorp arg) (recordp arg))
|
||||
(let ((hash (gethash arg byte-run--ssp-seen)))
|
||||
(if hash
|
||||
arg
|
||||
(let* ((len (length arg))
|
||||
(i 0)
|
||||
new)
|
||||
(puthash arg t byte-run--ssp-seen)
|
||||
(while (< i len)
|
||||
(setq new (byte-run--strip-s-p-1 (aref arg i)))
|
||||
(aset arg i new)
|
||||
(setq i (1+ i)))
|
||||
arg))))
|
||||
|
||||
(t arg))))
|
||||
(defalias 'byte-run--strip-vector/record
|
||||
#'(lambda (arg)
|
||||
"Strip the positions from symbols with position in the vector/record ARG.
|
||||
This is done by destructively modifying ARG. Return ARG."
|
||||
(unless (gethash arg byte-run--ssp-seen)
|
||||
(let ((len (length arg))
|
||||
(i 0)
|
||||
elt)
|
||||
(puthash arg t byte-run--ssp-seen)
|
||||
(while (< i len)
|
||||
(setq elt (aref arg i))
|
||||
(cond
|
||||
((symbol-with-pos-p elt)
|
||||
(aset arg i elt))
|
||||
((consp elt)
|
||||
(byte-run--strip-list elt))
|
||||
((or (vectorp elt) (recordp elt))
|
||||
(byte-run--strip-vector/record elt))))))
|
||||
arg))
|
||||
|
||||
(defalias 'byte-run-strip-symbol-positions
|
||||
#'(lambda (arg)
|
||||
"Strip all positions from symbols in ARG.
|
||||
This modifies destructively then returns ARG.
|
||||
|
||||
ARG is any Lisp object, but is usually a list or a vector or a
|
||||
record, containing symbols with position."
|
||||
(setq byte-run--ssp-seen (make-hash-table :test 'eq))
|
||||
(byte-run--strip-s-p-1 arg)))
|
||||
(cond
|
||||
((symbol-with-pos-p arg)
|
||||
(bare-symbol arg))
|
||||
((consp arg)
|
||||
(byte-run--strip-list arg))
|
||||
((or (vectorp arg) (recordp arg))
|
||||
(byte-run--strip-vector/record arg))
|
||||
(t arg))))
|
||||
|
||||
(defalias 'function-put
|
||||
;; We don't want people to just use `put' because we can't conveniently
|
||||
|
|
@ -92,9 +108,7 @@ Return the modified ARG."
|
|||
"Set FUNCTION's property PROP to VALUE.
|
||||
The namespace for PROP is shared with symbols.
|
||||
So far, FUNCTION can only be a symbol, not a lambda expression."
|
||||
(put (bare-symbol function)
|
||||
(byte-run-strip-symbol-positions prop)
|
||||
(byte-run-strip-symbol-positions value))))
|
||||
(put (bare-symbol function) prop value)))
|
||||
(function-put 'defmacro 'doc-string-elt 3)
|
||||
(function-put 'defmacro 'lisp-indent-function 2)
|
||||
|
||||
|
|
|
|||
|
|
@ -5099,7 +5099,7 @@ binding slots have been popped."
|
|||
OP and OPERAND are as passed to `byte-compile-out'."
|
||||
(if (memq op '(byte-call byte-discardN byte-discardN-preserve-tos))
|
||||
;; For calls, OPERAND is the number of args, so we pop OPERAND + 1
|
||||
;; elements, and the push the result, for a total of -OPERAND.
|
||||
;; elements, and then push the result, for a total of -OPERAND.
|
||||
;; For discardN*, of course, we just pop OPERAND elements.
|
||||
(- operand)
|
||||
(or (aref byte-stack+-info (symbol-value op))
|
||||
|
|
@ -5109,7 +5109,6 @@ OP and OPERAND are as passed to `byte-compile-out'."
|
|||
(- 1 operand))))
|
||||
|
||||
(defun byte-compile-out (op &optional operand)
|
||||
(setq operand (byte-run-strip-symbol-positions operand))
|
||||
(push (cons op operand) byte-compile-output)
|
||||
(if (eq op 'byte-return)
|
||||
;; This is actually an unnecessary case, because there should be no
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue