diff options
Diffstat (limited to 'lisp/subr.el')
| -rw-r--r-- | lisp/subr.el | 245 |
1 files changed, 175 insertions, 70 deletions
diff --git a/lisp/subr.el b/lisp/subr.el index f8ac70edefa..914112ccef5 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -78,8 +78,8 @@ If FORM does return, signal an error." (defmacro 1value (form) "Evaluate FORM, expecting a constant return value. -This is the global do-nothing version. There is also `testcover-1value' -that complains if FORM ever does return differing values." +If FORM returns differing values when running under Testcover, +Testcover will raise an error." (declare (debug t)) form) @@ -223,7 +223,7 @@ Then evaluate RESULT to get return value, default nil. "Loop a certain number of times. Evaluate BODY with VAR bound to successive integers running from 0, inclusive, to COUNT, exclusive. Then evaluate RESULT to get -the return value (nil if RESULT is omitted). +the return value (nil if RESULT is omitted). Its use is deprecated. \(fn (VAR COUNT [RESULT]) BODY...)" (declare (indent 1) (debug dolist)) @@ -680,20 +680,6 @@ If TEST is omitted or nil, `equal' is used." (setq tail (cdr tail))) value)) -(defun assoc-ignore-case (key alist) - "Like `assoc', but ignores differences in case and text representation. -KEY must be a string. Upper-case and lower-case letters are treated as equal. -Unibyte strings are converted to multibyte for comparison." - (declare (obsolete assoc-string "22.1")) - (assoc-string key alist t)) - -(defun assoc-ignore-representation (key alist) - "Like `assoc', but ignores differences in text representation. -KEY must be a string. -Unibyte strings are converted to multibyte for comparison." - (declare (obsolete assoc-string "22.1")) - (assoc-string key alist nil)) - (defun member-ignore-case (elt list) "Like `member', but ignore differences in case and text representation. ELT must be a string. Upper-case and lower-case letters are treated as equal. @@ -705,21 +691,29 @@ Non-strings in LIST are ignored." (setq list (cdr list))) list) -(defun assq-delete-all (key alist) - "Delete from ALIST all elements whose car is `eq' to KEY. +(defun assoc-delete-all (key alist &optional test) + "Delete from ALIST all elements whose car is KEY. +Compare keys with TEST. Defaults to `equal'. Return the modified alist. Elements of ALIST that are not conses are ignored." + (unless test (setq test #'equal)) (while (and (consp (car alist)) - (eq (car (car alist)) key)) + (funcall test (caar alist) key)) (setq alist (cdr alist))) (let ((tail alist) tail-cdr) (while (setq tail-cdr (cdr tail)) (if (and (consp (car tail-cdr)) - (eq (car (car tail-cdr)) key)) + (funcall test (caar tail-cdr) key)) (setcdr tail (cdr tail-cdr)) (setq tail tail-cdr)))) alist) +(defun assq-delete-all (key alist) + "Delete from ALIST all elements whose car is `eq' to KEY. +Return the modified alist. +Elements of ALIST that are not conses are ignored." + (assoc-delete-all key alist #'eq)) + (defun rassq-delete-all (value alist) "Delete from ALIST all elements whose cdr is `eq' to VALUE. Return the modified alist. @@ -1440,8 +1434,17 @@ be a list of the form returned by `event-start' and `event-end'." (make-obsolete 'forward-point "use (+ (point) N) instead." "23.1") (make-obsolete 'buffer-has-markers-at nil "24.3") +(make-obsolete 'invocation-directory "use the variable of the same name." + "27.1") +(make-obsolete 'invocation-name "use the variable of the same name." "27.1") + +;; We used to declare string-to-unibyte obsolete, but it is a valid +;; way of getting a unibyte string that can be indexed by bytes, when +;; the original string has raw bytes in their internal multibyte +;; representation. This can be useful when one needs to examine +;; individual bytes at known offsets from the string beginning. +;; (make-obsolete 'string-to-unibyte "use `encode-coding-string'." "26.1") ;; bug#23850 -(make-obsolete 'string-to-unibyte "use `encode-coding-string'." "26.1") (make-obsolete 'string-as-unibyte "use `encode-coding-string'." "26.1") (make-obsolete 'string-make-unibyte "use `encode-coding-string'." "26.1") (make-obsolete 'string-to-multibyte "use `decode-coding-string'." "26.1") @@ -1453,17 +1456,13 @@ be a list of the form returned by `event-start' and `event-end'." (declare (obsolete log "24.4")) (log x 10)) -;; These are used by VM and some old programs -(defalias 'focus-frame 'ignore "") -(make-obsolete 'focus-frame "it does nothing." "22.1") -(defalias 'unfocus-frame 'ignore "") -(make-obsolete 'unfocus-frame "it does nothing." "22.1") - (set-advertised-calling-convention 'all-completions '(string collection &optional predicate) "23.1") (set-advertised-calling-convention 'unintern '(name obarray) "23.3") (set-advertised-calling-convention 'indirect-function '(object) "25.1") (set-advertised-calling-convention 'redirect-frame-focus '(frame focus-frame) "24.3") +(set-advertised-calling-convention 'libxml-parse-xml-region '(start end &optional base-url) "27.1") +(set-advertised-calling-convention 'libxml-parse-html-region '(start end &optional base-url) "27.1") ;;;; Obsolescence declarations for variables, and aliases. @@ -1481,15 +1480,6 @@ be a list of the form returned by `event-start' and `event-end'." (make-obsolete-variable 'command-debug-status "expect it to be removed in a future version." "25.2") -;; Lisp manual only updated in 22.1. -(define-obsolete-variable-alias 'executing-macro 'executing-kbd-macro - "before 19.34") - -(define-obsolete-variable-alias 'x-lost-selection-hooks - 'x-lost-selection-functions "22.1") -(define-obsolete-variable-alias 'x-sent-selection-hooks - 'x-sent-selection-functions "22.1") - ;; This was introduced in 21.4 for pre-unicode unification. That ;; usage was rendered obsolete in 23.1 which uses Unicode internally. ;; Other uses are possible, so this variable is not _really_ obsolete, @@ -1813,7 +1803,7 @@ variable. The possible values of maximum length have the same meaning as the values of `history-length'. Remove duplicates of NEWELT if `history-delete-duplicates' is non-nil. If optional fourth arg KEEP-ALL is non-nil, add NEWELT to history even -if it is empty or a duplicate." +if it is empty or duplicates the most recent entry in the history." (unless maxelt (setq maxelt (or (get history-var 'history-length) history-length))) @@ -1829,27 +1819,25 @@ if it is empty or a duplicate." (setq history (delete newelt history))) (setq history (cons newelt history)) (when (integerp maxelt) - (if (= 0 maxelt) + (if (>= 0 maxelt) (setq history nil) (setq tail (nthcdr (1- maxelt) history)) (when (consp tail) - (setcdr tail nil))))) - (set history-var history))) + (setcdr tail nil)))) + (set history-var history)))) ;;;; Mode hooks. (defvar delay-mode-hooks nil "If non-nil, `run-mode-hooks' should delay running the hooks.") -(defvar delayed-mode-hooks nil +(defvar-local delayed-mode-hooks nil "List of delayed mode hooks waiting to be run.") -(make-variable-buffer-local 'delayed-mode-hooks) (put 'delay-mode-hooks 'permanent-local t) -(defvar delayed-after-hook-functions nil +(defvar-local delayed-after-hook-functions nil "List of delayed :after-hook forms waiting to be run. These forms come from `define-derived-mode'.") -(make-variable-buffer-local 'delayed-after-hook-functions) (defvar change-major-mode-after-body-hook nil "Normal hook run in major mode functions, before the mode hooks.") @@ -1878,15 +1866,22 @@ running their FOO-mode-hook." (push hook delayed-mode-hooks)) ;; Normal case, just run the hook as before plus any delayed hooks. (setq hooks (nconc (nreverse delayed-mode-hooks) hooks)) + (and syntax-propertize-function + (not (local-variable-p 'parse-sexp-lookup-properties)) + ;; `syntax-propertize' sets `parse-sexp-lookup-properties' for us, but + ;; in order for the sexp primitives to automatically call + ;; `syntax-propertize' we need `parse-sexp-lookup-properties' to be + ;; set first. + (setq-local parse-sexp-lookup-properties t)) (setq delayed-mode-hooks nil) - (apply 'run-hooks (cons 'change-major-mode-after-body-hook hooks)) + (apply #'run-hooks (cons 'change-major-mode-after-body-hook hooks)) (if (buffer-file-name) (with-demoted-errors "File local-variables error: %s" (hack-local-variables 'no-mode))) (run-hooks 'after-change-major-mode-hook) - (dolist (fun (nreverse delayed-after-hook-functions)) - (funcall fun)) - (setq delayed-after-hook-functions nil))) + (dolist (fun (prog1 (nreverse delayed-after-hook-functions) + (setq delayed-after-hook-functions nil))) + (funcall fun)))) (defmacro delay-mode-hooks (&rest body) "Execute BODY, but delay any `run-mode-hooks'. @@ -2162,19 +2157,6 @@ process." (memq (process-status process) '(run open listen connect stop)))) -;; compatibility - -(defun process-kill-without-query (process &optional _flag) - "Say no query needed if PROCESS is running when Emacs is exited. -Optional second argument if non-nil says to require a query. -Value is t if a query was formerly required." - (declare (obsolete - "use `process-query-on-exit-flag' or `set-process-query-on-exit-flag'." - "22.1")) - (let ((old (process-query-on-exit-flag process))) - (set-process-query-on-exit-flag process nil) - old)) - (defun process-kill-buffer-query-function () "Ask before killing a buffer that has a running process." (let ((process (get-buffer-process (current-buffer)))) @@ -2575,7 +2557,7 @@ is nil and `use-dialog-box' is non-nil." ;;; Atomic change groups. (defmacro atomic-change-group (&rest body) - "Perform BODY as an atomic change group. + "Like `progn' but perform BODY as an atomic change group. This means that if BODY exits abnormally, all of its changes to the current buffer are undone. This works regardless of whether undo is enabled in the buffer. @@ -2598,8 +2580,8 @@ user can undo the change normally." ;; it enables undo if that was disabled; we need ;; to make sure that it gets disabled again. (activate-change-group ,handle) - ,@body - (setq ,success t)) + (prog1 ,(macroexp-progn body) + (setq ,success t))) ;; Either of these functions will disable undo ;; if it was disabled before. (if ,success @@ -3597,6 +3579,119 @@ in BODY." . ,body) (combine-after-change-execute))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defvar undo--combining-change-calls nil + "Non-nil when `combine-change-calls-1' is running.") + +(defun combine-change-calls-1 (beg end body) + "Evaluate BODY, running the change hooks just once, for region \(BEG END). + +Firstly, `before-change-functions' is invoked for the region +\(BEG END), then BODY (a function) is evaluated with +`before-change-functions' and `after-change-functions' bound to +nil, then finally `after-change-functions' is invoked on the +updated region (BEG NEW-END) with a calculated OLD-LEN argument. +If `inhibit-modification-hooks' is initially non-nil, the change +hooks are not run. + +The result of `combine-change-calls-1' is the value returned by +BODY. BODY must not make a different buffer current, except +temporarily. It must not make any changes to the buffer outside +the specified region. It must not change +`before-change-functions' or `after-change-functions'. + +Additionally, the buffer modifications of BODY are recorded on +the buffer's undo list as a single \(apply ...) entry containing +the function `undo--wrap-and-run-primitive-undo'." + (let ((old-bul buffer-undo-list) + (end-marker (copy-marker end t)) + result) + (if undo--combining-change-calls + (setq result (funcall body)) + (let ((undo--combining-change-calls t)) + (if (not inhibit-modification-hooks) + (run-hook-with-args 'before-change-functions beg end)) + (if (eq buffer-undo-list t) + (setq result (funcall body)) + (let (;; (inhibit-modification-hooks t) + before-change-functions after-change-functions) + (setq result (funcall body))) + (let ((ap-elt + (list 'apply + (- end end-marker) + beg + (marker-position end-marker) + #'undo--wrap-and-run-primitive-undo + beg (marker-position end-marker) buffer-undo-list)) + (ptr buffer-undo-list)) + (if (not (eq buffer-undo-list old-bul)) + (progn + (while (and (not (eq (cdr ptr) old-bul)) + ;; In case garbage collection has removed OLD-BUL. + (cdr ptr) + ;; Don't include a timestamp entry. + (not (and (consp (cdr ptr)) + (consp (cadr ptr)) + (eq (caadr ptr) t) + (setq old-bul (cdr ptr))))) + (setq ptr (cdr ptr))) + (unless (cdr ptr) + (message "combine-change-calls: buffer-undo-list broken")) + (setcdr ptr nil) + (push ap-elt buffer-undo-list) + (setcdr buffer-undo-list old-bul))))) + (if (not inhibit-modification-hooks) + (run-hook-with-args 'after-change-functions + beg (marker-position end-marker) + (- end beg))))) + (set-marker end-marker nil) + result)) + +(defmacro combine-change-calls (beg end &rest body) + "Evaluate BODY, running the change hooks just once. + +BODY is a sequence of lisp forms to evaluate. BEG and END bound +the region the change hooks will be run for. + +Firstly, `before-change-functions' is invoked for the region +\(BEG END), then the BODY forms are evaluated with +`before-change-functions' and `after-change-functions' bound to +nil, and finally `after-change-functions' is invoked on the +updated region. The change hooks are not run if +`inhibit-modification-hooks' is initially non-nil. + +The result of `combine-change-calls' is the value returned by the +last of the BODY forms to be evaluated. BODY may not make a +different buffer current, except temporarily. BODY may not +change the buffer outside the specified region. It must not +change `before-change-functions' or `after-change-functions'. + +Additionally, the buffer modifications of BODY are recorded on +the buffer's undo list as a single \(apply ...) entry containing +the function `undo--wrap-and-run-primitive-undo'. " + `(combine-change-calls-1 ,beg ,end (lambda () ,@body))) + +(defun undo--wrap-and-run-primitive-undo (beg end list) + "Call `primitive-undo' on the undo elements in LIST. + +This function is intended to be called purely by `undo' as the +function in an \(apply DELTA BEG END FUNNAME . ARGS) undo +element. It invokes `before-change-functions' and +`after-change-functions' once each for the entire region \(BEG +END) rather than once for each individual change. + +Additionally the fresh \"redo\" elements which are generated on +`buffer-undo-list' will themselves be \"enclosed\" in +`undo--wrap-and-run-primitive-undo'. + +Undo elements of this form are generated by the macro +`combine-change-calls'." + (combine-change-calls beg end + (while list + (setq list (primitive-undo 1 list))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (defmacro with-case-table (table &rest body) "Execute the forms in BODY with TABLE as the current case table. The value returned is the value of the last form in BODY." @@ -4238,14 +4333,24 @@ to `display-warning'." (defun add-to-invisibility-spec (element) "Add ELEMENT to `buffer-invisibility-spec'. See documentation for `buffer-invisibility-spec' for the kind of elements -that can be added." +that can be added. + +If `buffer-invisibility-spec' isn't a list before calling this +function, `buffer-invisibility-spec' will afterwards be a list +with the value `(t ELEMENT)'. This means that if text exists +that invisibility values that aren't either `t' or ELEMENT, that +text will become visible." (if (eq buffer-invisibility-spec t) (setq buffer-invisibility-spec (list t))) (setq buffer-invisibility-spec (cons element buffer-invisibility-spec))) (defun remove-from-invisibility-spec (element) - "Remove ELEMENT from `buffer-invisibility-spec'." + "Remove ELEMENT from `buffer-invisibility-spec'. +If `buffer-invisibility-spec' isn't a list before calling this +function, it will be made into a list containing just `t' as the +only list member. This means that if text exists with non-`t' +invisibility values, that text will become visible." (setq buffer-invisibility-spec (if (consp buffer-invisibility-spec) (delete element buffer-invisibility-spec) @@ -4530,10 +4635,10 @@ EVALD, FUNC, ARGS, FLAGS are as in `mapbacktrace'." (princ (if (plist-get flags :debug-on-exit) "* " " ")) (cond ((and evald (not debugger-stack-frame-as-list)) - (prin1 func) - (if args (prin1 args) (princ "()"))) + (cl-prin1 func) + (if args (cl-prin1 args) (princ "()"))) (t - (prin1 (cons func args)))) + (cl-prin1 (cons func args)))) (princ "\n")) (defun backtrace () |