diff options
Diffstat (limited to 'lisp/emacs-lisp/byte-run.el')
| -rw-r--r-- | lisp/emacs-lisp/byte-run.el | 85 |
1 files changed, 83 insertions, 2 deletions
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 47f331fd9d0..fedc10cea44 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -30,6 +30,83 @@ ;;; Code: +(defvar byte-run--ssp-seen nil + "Which conses/vectors/records have been processed in strip-symbol-positions? +The value is a hash table, the key being the old element and the value being +the corresponding new element of the same type. + +The purpose of this is to detect circular structures.") + +(defalias 'byte-run--circular-list-p + #'(lambda (l) + "Return non-nil when the list L is a circular list. +Note that this algorithm doesn't check any circularity in the +CARs of list elements." + (let ((hare l) + (tortoise l)) + (condition-case err + (progn + (while (progn + (setq hare (cdr (cdr hare)) + tortoise (cdr tortoise)) + (not (or (eq tortoise hare) + (null hare))))) + (eq tortoise hare)) + (wrong-type-argument nil) + (error (signal (car err) (cdr err))))))) + +(defalias 'byte-run--strip-s-p-1 + #'(lambda (arg) + "Strip all positions from symbols in ARG, modifying ARG. +Return the modified ARG." + (cond + ((symbol-with-pos-p arg) + (bare-symbol arg)) + + ((consp arg) + (let* ((round (byte-run--circular-list-p arg)) + (hash (and round (gethash arg byte-run--ssp-seen)))) + (or hash + (let ((a arg) new) + (while + (progn + (when round + (puthash a new byte-run--ssp-seen)) + (setq new (byte-run--strip-s-p-1 (car a))) + (when (not (eq new (car a))) ; For read-only things. + (setcar a new)) + (and (consp (cdr a)) + (not + (setq hash + (and round + (gethash (cdr a) byte-run--ssp-seen)))))) + (setq a (cdr a))) + (setq new (byte-run--strip-s-p-1 (cdr a))) + (when (not (eq new (cdr a))) + (setcdr a (or hash new))) + arg)))) + + ((or (vectorp arg) (recordp arg)) + (let ((hash (gethash arg byte-run--ssp-seen))) + (or hash + (let* ((len (length arg)) + (i 0) + new) + (puthash arg arg byte-run--ssp-seen) + (while (< i len) + (setq new (byte-run--strip-s-p-1 (aref arg i))) + (when (not (eq new (aref arg i))) + (aset arg i new)) + (setq i (1+ i))) + arg)))) + + (t arg)))) + +(defalias 'byte-run-strip-symbol-positions + #'(lambda (arg) + (setq byte-run--ssp-seen (make-hash-table :test 'eq)) + (byte-run--strip-s-p-1 arg))) + (defalias 'function-put ;; We don't want people to just use `put' because we can't conveniently ;; hook into `put' to remap old properties to new ones. But for now, there's @@ -38,7 +115,9 @@ "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 function prop value))) + (put (bare-symbol function) + (byte-run-strip-symbol-positions prop) + (byte-run-strip-symbol-positions value)))) (function-put 'defmacro 'doc-string-elt 3) (function-put 'defmacro 'lisp-indent-function 2) @@ -254,7 +333,8 @@ The return value is undefined. #'(lambda (x) (let ((f (cdr (assq (car x) macro-declarations-alist)))) (if f (apply (car f) name arglist (cdr x)) - (macroexp-warn-and-return + (macroexp-warn-and-return + (car x) (format-message "Unknown macro property %S in %S" (car x) name) @@ -328,6 +408,7 @@ The return value is undefined. nil) (t (macroexp-warn-and-return + (car x) (format-message "Unknown defun property `%S' in %S" (car x) name) nil))))) |