If the value is nil, `pop' returns nil but does not actually
change the list."
(declare (debug (gv-place)))
- (list 'car
- (if (symbolp place)
- ;; So we can use `pop' in the bootstrap before `gv' can be used.
- (list 'prog1 place (list 'setq place (list 'cdr place)))
- (gv-letplace (getter setter) place
- `(prog1 ,getter ,(funcall setter `(cdr ,getter)))))))
+ ;; We use `car-safe' here instead of `car' because the behavior is the same
+ ;; (if it's not a cons cell, the `cdr' would have signaled an error already),
+ ;; but `car-safe' is total, so the byte-compiler can safely remove it if the
+ ;; result is not used.
+ `(car-safe
+ ,(if (symbolp place)
+ ;; So we can use `pop' in the bootstrap before `gv' can be used.
+ (list 'prog1 place (list 'setq place (list 'cdr place)))
+ (gv-letplace (getter setter) place
+ `(prog1 ,getter ,(funcall setter `(cdr ,getter)))))))
(defmacro when (cond &rest body)
"If COND yields non-nil, do BODY, else return nil.
In Emacs, the convention is that error messages start with a capital
letter but *do not* end with a period. Please follow this convention
for the sake of consistency."
+ (declare (advertised-calling-convention (string &rest args) "23.1"))
(while t
(signal 'error (list (apply 'format args)))))
-(set-advertised-calling-convention 'error '(string &rest args) "23.1")
(defun user-error (format &rest args)
"Signal a pilot error, making error message by passing all args to `format'.
(while t
(signal 'user-error (list (apply #'format format args)))))
+(defun define-error (name message &optional parent)
+ "Define NAME as a new error signal.
+MESSAGE is a string that will be output to the echo area if such an error
+is signaled without being caught by a `condition-case'.
+PARENT is either a signal or a list of signals from which it inherits.
+Defaults to `error'."
+ (unless parent (setq parent 'error))
+ (let ((conditions
+ (if (consp parent)
+ (apply #'nconc
+ (mapcar (lambda (parent)
+ (cons parent
+ (or (get parent 'error-conditions)
+ (error "Unknown signal `%s'" parent))))
+ parent))
+ (cons parent (get parent 'error-conditions)))))
+ (put name 'error-conditions
+ (delete-dups (copy-sequence (cons name conditions))))
+ (when message (put name 'error-message message))))
+
;; We put this here instead of in frame.el so that it's defined even on
;; systems where frame.el isn't loaded.
(defun frame-configuration-p (object)
(declare (obsolete make-hash-table "22.1"))
(make-hash-table :test (or test 'eql)))
+(defun log10 (x)
+ "Return (log X 10), the log base 10 of X."
+ (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")
'all-completions '(string collection &optional predicate) "23.1")
(set-advertised-calling-convention 'unintern '(name obarray) "23.3")
(set-advertised-calling-convention 'redirect-frame-focus '(frame focus-frame) "24.3")
+(set-advertised-calling-convention 'decode-char '(ch charset) "21.4")
+(set-advertised-calling-convention 'encode-char '(ch charset) "21.4")
\f
;;;; Obsolescence declarations for variables, and aliases.
(setq local t)))
(let ((hook-value (if local (symbol-value hook) (default-value hook))))
;; If the hook value is a single function, turn it into a list.
- (when (or (not (listp hook-value)) (eq (car hook-value) 'lambda))
+ (when (or (not (listp hook-value)) (functionp hook-value))
(setq hook-value (list hook-value)))
;; Do the actual addition if necessary
(unless (member function hook-value)
;; FIXME: Something like this could be used for `set' as well.
(if (or (not (eq 'quote (car-safe list-var)))
(special-variable-p (cadr list-var))
- (and append compare-fn))
+ (not (macroexp-const-p append)))
exp
(let* ((sym (cadr list-var))
+ (append (eval append))
(msg (format "`add-to-list' can't use lexical var `%s'; use `push' or `cl-pushnew'"
sym))
;; Big ugly hack so we only output a warning during
(when (assq sym byte-compile--lexical-environment)
(byte-compile-log-warning msg t :error))))
(code
- (if append
- (macroexp-let2 macroexp-copyable-p x element
- `(unless (member ,x ,sym)
- (setq ,sym (append ,sym (list ,x)))))
- (require 'cl-lib)
- `(cl-pushnew ,element ,sym
- :test ,(or compare-fn '#'equal)))))
+ (macroexp-let2 macroexp-copyable-p x element
+ `(unless ,(if compare-fn
+ (progn
+ (require 'cl-lib)
+ `(cl-member ,x ,sym :test ,compare-fn))
+ ;; For bootstrapping reasons, don't rely on
+ ;; cl--compiler-macro-member for the base case.
+ `(member ,x ,sym))
+ ,(if append
+ `(setq ,sym (append ,sym (list ,x)))
+ `(push ,x ,sym))))))
(if (not (macroexp--compiling-p))
code
`(progn
The optional argument PROMPT specifies a string to use to prompt the user.
The variable `read-quoted-char-radix' controls which radix to use
for numeric input."
- (let ((message-log-max nil) done (first t) (code 0) char translated)
+ (let ((message-log-max nil) done (first t) (code 0) translated)
(while (not done)
(let ((inhibit-quit first)
;; Don't let C-h get the help message--only help function keys.
or the octal character code.
RET terminates the character code and is discarded;
any other non-digit terminates the character code and is then used as input."))
- (setq char (read-event (and prompt (format "%s-" prompt)) t))
+ (setq translated (read-key (and prompt (format "%s-" prompt))))
(if inhibit-quit (setq quit-flag nil)))
- ;; Translate TAB key into control-I ASCII character, and so on.
- ;; Note: `read-char' does it using the `ascii-character' property.
- ;; We should try and use read-key instead.
- (let ((translation (lookup-key local-function-key-map (vector char))))
- (setq translated (if (arrayp translation)
- (aref translation 0)
- char)))
(if (integerp translated)
(setq translated (char-resolve-modifiers translated)))
(cond ((null translated))
((not (integerp translated))
- (setq unread-command-events (list char)
+ (setq unread-command-events
+ (listify-key-sequence (this-single-command-raw-keys))
done t))
((/= (logand translated ?\M-\^@) 0)
;; Turn a meta-character into a character with the 0200 bit set.
((and (not first) (eq translated ?\C-m))
(setq done t))
((not first)
- (setq unread-command-events (list char)
+ (setq unread-command-events
+ (listify-key-sequence (this-single-command-raw-keys))
done t))
(t (setq code translated
done t)))
(setq-local buffer-undo-list t)
(setq-local select-active-regions nil)
(use-local-map read-passwd-map)
+ (setq-local inhibit-modification-hooks nil) ;bug#15501.
(add-hook 'after-change-functions hide-chars-fun nil 'local))
(unwind-protect
(let ((enable-recursive-minibuffers t))
where the optional arg MILLISECONDS specifies an additional wait period,
in milliseconds; this was useful when Emacs was built without
floating point support."
+ (declare (advertised-calling-convention (seconds &optional nodisp) "22.1"))
(if (numberp nodisp)
(setq seconds (+ seconds (* 1e-3 nodisp))
nodisp obsolete)
(or nodisp (redisplay)))
(t
(or nodisp (redisplay))
- (let ((read (read-event nil nil seconds)))
+ ;; FIXME: we should not read-event here at all, because it's much too
+ ;; difficult to reliably "undo" a read-event by pushing it onto
+ ;; unread-command-events.
+ (let ((read (read-event nil t seconds)))
(or (null read)
(progn
;; If last command was a prefix arg, e.g. C-u, push this event onto
(setq read (cons t read)))
(push read unread-command-events)
nil))))))
-(set-advertised-calling-convention 'sit-for '(seconds &optional nodisp) "22.1")
+
+;; Behind display-popup-menus-p test.
+(declare-function x-popup-dialog "xmenu.c" (position contents &optional header))
(defun y-or-n-p (prompt)
"Ask user a \"y or n\" question. Return t if answer is \"y\".
(cond
(noninteractive
(setq prompt (concat prompt
- (if (eq ?\s (aref prompt (1- (length prompt))))
+ (if (or (zerop (length prompt))
+ (eq ?\s (aref prompt (1- (length prompt)))))
"" " ")
"(y or n) "))
(let ((temp-prompt prompt))
(x-popup-dialog t `(,prompt ("Yes" . act) ("No" . skip)))))
(t
(setq prompt (concat prompt
- (if (eq ?\s (aref prompt (1- (length prompt))))
+ (if (or (zerop (length prompt))
+ (eq ?\s (aref prompt (1- (length prompt)))))
"" " ")
"(y or n) "))
(while
(recenter (/ (window-height) 2))))
(message (or message "Type %s to continue editing.")
(single-key-description exit-char))
- (let ((event (read-event)))
+ (let ((event (read-key)))
;; `exit-char' can be an event, or an event description list.
(or (eq event exit-char)
(eq event (event-convert-list exit-char))
- (setq unread-command-events (list event)))))
+ (setq unread-command-events
+ (append (this-single-command-raw-keys))))))
(delete-overlay ol))))
\f
This hook is normally set up with a function to put the buffer in Help
mode.")
-;; The `assert' macro from the cl package signals
-;; `cl-assertion-failed' at runtime so always define it.
-(put 'cl-assertion-failed 'error-conditions '(error))
-(put 'cl-assertion-failed 'error-message (purecopy "Assertion failed"))
-
(defconst user-emacs-directory
(if (eq system-type 'ms-dos)
;; MS-DOS cannot have initial dot.
(setq object (indirect-function object t)))
(and (subrp object) (eq (cdr (subr-arity object)) 'unevalled)))
+(defun macrop (object)
+ "Non-nil if and only if OBJECT is a macro."
+ (let ((def (indirect-function object t)))
+ (when (consp def)
+ (or (eq 'macro (car def))
+ (and (autoloadp def) (memq (nth 4 def) '(macro t)))))))
+
(defun field-at-pos (pos)
"Return the field at position POS, taking stickiness etc into account."
(let ((raw-field (get-char-property (field-beginning pos) 'field)))
(define-obsolete-function-alias 'condition-case-no-debug
'condition-case-unless-debug "24.1")
-(defmacro with-demoted-errors (&rest body)
+(defmacro with-demoted-errors (format &rest body)
"Run BODY and demote any errors to simple messages.
If `debug-on-error' is non-nil, run BODY without catching its errors.
This is to be used around code which is not expected to signal an error
-but which should be robust in the unexpected case that an error is signaled."
- (declare (debug t) (indent 0))
- (let ((err (make-symbol "err")))
+but which should be robust in the unexpected case that an error is signaled.
+For backward compatibility, if FORMAT is not a constant string, it
+is assumed to be part of BODY, in which case the message format
+used is \"Error: %S\"."
+ (declare (debug t) (indent 1))
+ (let ((err (make-symbol "err"))
+ (format (if (and (stringp format) body) format
+ (prog1 "Error: %S"
+ (if format (push format body))))))
`(condition-case-unless-debug ,err
- (progn ,@body)
- (error (message "Error: %S" ,err) nil))))
+ ,(macroexp-progn body)
+ (error (message ,format ,err) nil))))
(defmacro combine-after-change-calls (&rest body)
"Execute BODY, but don't call the after-change functions till the end.
possible, stopping when a single additional previous character
cannot be part of a match for REGEXP. When the match is
extended, its starting position is allowed to occur before
-LIMIT."
+LIMIT.
+
+As a general recommendation, try to avoid using `looking-back'
+wherever possible, since it is slow."
(let ((start (point))
(pos
(save-excursion
;; defaulted, OMIT-NULLS should be treated as t. Simplifying the logical
;; expression leads to the equivalent implementation that if SEPARATORS
;; is defaulted, OMIT-NULLS is treated as t.
-(defun split-string (string &optional separators omit-nulls)
+(defun split-string (string &optional separators omit-nulls trim)
"Split STRING into substrings bounded by matches for SEPARATORS.
The beginning and end of STRING, and each match for SEPARATORS, are
are effectively trimmed). If nil, all zero-length substrings are retained,
which correctly parses CSV format, for example.
+If TRIM is non-nil, it should be a regular expression to match
+text to trim from the beginning and end of each substring. If trimming
+makes the substring empty, it is treated as null.
+
+If you want to trim whitespace from the substrings, the reliably correct
+way is using TRIM. Making SEPARATORS match that whitespace gives incorrect
+results when there is whitespace at the start or end of STRING. If you
+see such calls to `split-string', please fix them.
+
Note that the effect of `(split-string STRING)' is the same as
`(split-string STRING split-string-default-separators t)'. In the rare
case that you wish to retain zero-length substrings when splitting on
whitespace, use `(split-string STRING split-string-default-separators)'.
Modifies the match data; use `save-match-data' if necessary."
- (let ((keep-nulls (not (if separators omit-nulls t)))
- (rexp (or separators split-string-default-separators))
- (start 0)
- notfirst
- (list nil))
+ (let* ((keep-nulls (not (if separators omit-nulls t)))
+ (rexp (or separators split-string-default-separators))
+ (start 0)
+ this-start this-end
+ notfirst
+ (list nil)
+ (push-one
+ ;; Push the substring in range THIS-START to THIS-END
+ ;; onto LIST, trimming it and perhaps discarding it.
+ (lambda ()
+ (when trim
+ ;; Discard the trim from start of this substring.
+ (let ((tem (string-match trim string this-start)))
+ (and (eq tem this-start)
+ (setq this-start (match-end 0)))))
+
+ (when (or keep-nulls (< this-start this-end))
+ (let ((this (substring string this-start this-end)))
+
+ ;; Discard the trim from end of this substring.
+ (when trim
+ (let ((tem (string-match (concat trim "\\'") this 0)))
+ (and tem (< tem (length this))
+ (setq this (substring this 0 tem)))))
+
+ ;; Trimming could make it empty; check again.
+ (when (or keep-nulls (> (length this) 0))
+ (push this list)))))))
+
(while (and (string-match rexp string
(if (and notfirst
(= start (match-beginning 0))
(1+ start) start))
(< start (length string)))
(setq notfirst t)
- (if (or keep-nulls (< start (match-beginning 0)))
- (setq list
- (cons (substring string start (match-beginning 0))
- list)))
- (setq start (match-end 0)))
- (if (or keep-nulls (< start (length string)))
- (setq list
- (cons (substring string start)
- list)))
+ (setq this-start start this-end (match-beginning 0)
+ start (match-end 0))
+
+ (funcall push-one))
+
+ ;; Handle the substring at the end of STRING.
+ (setq this-start start this-end (length string))
+ (funcall push-one)
+
(nreverse list)))
(defun combine-and-quote-strings (strings &optional separator)
(defun eval-after-load (file form)
"Arrange that if FILE is loaded, FORM will be run immediately afterwards.
If FILE is already loaded, evaluate FORM right now.
+FORM can be an Elisp expression (in which case it's passed to `eval'),
+or a function (in which case it's passed to `funcall' with no argument).
If a matching file is loaded again, FORM will be evaluated again.
like 'font-lock.
This function makes or adds to an entry on `after-load-alist'."
+ (declare (compiler-macro
+ (lambda (whole)
+ (if (eq 'quote (car-safe form))
+ ;; Quote with lambda so the compiler can look inside.
+ `(eval-after-load ,file (lambda () ,(nth 1 form)))
+ whole))))
;; Add this FORM into after-load-alist (regardless of whether we'll be
;; evaluating it now).
(let* ((regexp-or-feature
(if (stringp file)
(setq file (purecopy (load-history-regexp file)))
file))
- (elt (assoc regexp-or-feature after-load-alist)))
+ (elt (assoc regexp-or-feature after-load-alist))
+ (func
+ (if (functionp form) form
+ ;; Try to use the "current" lexical/dynamic mode for `form'.
+ (eval `(lambda () ,form) lexical-binding))))
(unless elt
(setq elt (list regexp-or-feature))
(push elt after-load-alist))
- ;; Make sure `form' is evalled in the current lexical/dynamic code.
- (setq form `(funcall ',(eval `(lambda () ,form) lexical-binding)))
;; Is there an already loaded file whose name (or `provide' name)
;; matches FILE?
(prog1 (if (if (stringp file)
(load-history-filename-element regexp-or-feature)
(featurep file))
- (eval form))
- (when (symbolp regexp-or-feature)
- ;; For features, the after-load-alist elements get run when `provide' is
- ;; called rather than at the end of the file. So add an indirection to
- ;; make sure that `form' is really run "after-load" in case the provide
- ;; call happens early.
- (setq form
- `(if load-file-name
- (let ((fun (make-symbol "eval-after-load-helper")))
- (fset fun `(lambda (file)
- (if (not (equal file ',load-file-name))
- nil
- (remove-hook 'after-load-functions ',fun)
- ,',form)))
- (add-hook 'after-load-functions fun))
- ;; Not being provided from a file, run form right now.
- ,form)))
- ;; Add FORM to the element unless it's already there.
- (unless (member form (cdr elt))
- (nconc elt (list form))))))
+ (funcall func))
+ (let ((delayed-func
+ (if (not (symbolp regexp-or-feature)) func
+ ;; For features, the after-load-alist elements get run when
+ ;; `provide' is called rather than at the end of the file.
+ ;; So add an indirection to make sure that `func' is really run
+ ;; "after-load" in case the provide call happens early.
+ (lambda ()
+ (if (not load-file-name)
+ ;; Not being provided from a file, run func right now.
+ (funcall func)
+ (let ((lfn load-file-name)
+ ;; Don't use letrec, because equal (in
+ ;; add/remove-hook) would get trapped in a cycle.
+ (fun (make-symbol "eval-after-load-helper")))
+ (fset fun (lambda (file)
+ (when (equal file lfn)
+ (remove-hook 'after-load-functions fun)
+ (funcall func))))
+ (add-hook 'after-load-functions fun 'append)))))))
+ ;; Add FORM to the element unless it's already there.
+ (unless (member delayed-func (cdr elt))
+ (nconc elt (list delayed-func)))))))
+
+(defmacro with-eval-after-load (file &rest body)
+ "Execute BODY after FILE is loaded.
+FILE is normally a feature name, but it can also be a file name,
+in case that file does not provide any feature."
+ (declare (indent 1) (debug t))
+ `(eval-after-load ,file (lambda () ,@body)))
(defvar after-load-functions nil
"Special hook run after loading a file.
ABS-FILE, a string, should be the absolute true name of a file just loaded.
This function is called directly from the C code."
;; Run the relevant eval-after-load forms.
- (mapc #'(lambda (a-l-element)
- (when (and (stringp (car a-l-element))
- (string-match-p (car a-l-element) abs-file))
- ;; discard the file name regexp
- (mapc #'eval (cdr a-l-element))))
- after-load-alist)
+ (dolist (a-l-element after-load-alist)
+ (when (and (stringp (car a-l-element))
+ (string-match-p (car a-l-element) abs-file))
+ ;; discard the file name regexp
+ (mapc #'funcall (cdr a-l-element))))
;; Complain when the user uses obsolete files.
(when (string-match-p "/obsolete/[^/]*\\'" abs-file)
- (run-with-timer 0 nil
- (lambda (file)
- (message "Package %s is obsolete!"
- (substring file 0
- (string-match "\\.elc?\\>" file))))
- (file-name-nondirectory abs-file)))
+ ;; Maybe we should just use display-warning? This seems yucky...
+ (let* ((file (file-name-nondirectory abs-file))
+ (msg (format "Package %s is obsolete!"
+ (substring file 0
+ (string-match "\\.elc?\\>" file)))))
+ ;; Cribbed from cl--compiling-file.
+ (if (and (boundp 'byte-compile--outbuffer)
+ (bufferp (symbol-value 'byte-compile--outbuffer))
+ (equal (buffer-name (symbol-value 'byte-compile--outbuffer))
+ " *Compiler Output*"))
+ ;; Don't warn about obsolete files using other obsolete files.
+ (unless (and (stringp byte-compile-current-file)
+ (string-match-p "/obsolete/[^/]*\\'"
+ (expand-file-name
+ byte-compile-current-file
+ byte-compile-root-dir)))
+ (byte-compile-log-warning msg))
+ (run-with-timer 0 nil
+ (lambda (msg)
+ (message "%s" msg)) msg))))
+
;; Finally, run any other hook.
(run-hook-with-args 'after-load-functions abs-file))
(declare (obsolete eval-after-load "23.2"))
(eval-after-load file (read)))
+\f
(defun display-delayed-warnings ()
"Display delayed warnings from `delayed-warnings-list'.
Used from `delayed-warnings-hook' (which see)."
warnings listed in `delayed-warnings-list', display them, and set
`delayed-warnings-list' back to nil.")
+(defun delay-warning (type message &optional level buffer-name)
+ "Display a delayed warning.
+Aside from going through `delayed-warnings-list', this is equivalent
+to `display-warning'."
+ (push (list type message level buffer-name) delayed-warnings-list))
+
\f
;;;; invisibility specs
\f
;;;; Text clones
-(defun text-clone-maintain (ol1 after beg end &optional _len)
+(defvar text-clone--maintaining nil)
+
+(defun text-clone--maintain (ol1 after beg end &optional _len)
"Propagate the changes made under the overlay OL1 to the other clones.
This is used on the `modification-hooks' property of text clones."
- (when (and after (not undo-in-progress) (overlay-start ol1))
+ (when (and after (not undo-in-progress)
+ (not text-clone--maintaining)
+ (overlay-start ol1))
(let ((margin (if (overlay-get ol1 'text-clone-spreadp) 1 0)))
(setq beg (max beg (+ (overlay-start ol1) margin)))
(setq end (min end (- (overlay-end ol1) margin)))
(tail (- (overlay-end ol1) end))
(str (buffer-substring beg end))
(nothing-left t)
- (inhibit-modification-hooks t))
+ (text-clone--maintaining t))
(dolist (ol2 (overlay-get ol1 'text-clones))
(let ((oe (overlay-end ol2)))
(unless (or (eq ol1 ol2) (null oe))
(unless (> mod-beg (point))
(save-excursion (insert str))
(delete-region mod-beg (point)))
- ;;(overlay-put ol2 'modification-hooks '(text-clone-maintain))
+ ;;(overlay-put ol2 'modification-hooks '(text-clone--maintain))
))))
(if nothing-left (delete-overlay ol1))))))))
(>= pt-end (point-max))
(>= start (point-max)))
0 1))
+ ;; FIXME: Reuse overlays at point to extend dups!
(ol1 (make-overlay (- start start-margin) (+ end end-margin) nil t))
(ol2 (make-overlay (- (point) start-margin) (+ pt-end end-margin) nil t))
(dups (list ol1 ol2)))
- (overlay-put ol1 'modification-hooks '(text-clone-maintain))
+ (overlay-put ol1 'modification-hooks '(text-clone--maintain))
(when spreadp (overlay-put ol1 'text-clone-spreadp t))
(when syntax (overlay-put ol1 'text-clone-syntax syntax))
;;(overlay-put ol1 'face 'underline)
(overlay-put ol1 'evaporate t)
(overlay-put ol1 'text-clones dups)
;;
- (overlay-put ol2 'modification-hooks '(text-clone-maintain))
+ (overlay-put ol2 'modification-hooks '(text-clone--maintain))
(when spreadp (overlay-put ol2 'text-clone-spreadp t))
(when syntax (overlay-put ol2 'text-clone-syntax syntax))
;;(overlay-put ol2 'face 'underline)
if those frames don't seem special and otherwise, it should return
the number of frames to skip (minus 1).")
-(defmacro internal--called-interactively-p--get-frame (n)
- ;; `sym' will hold a global variable, which will be used kind of like C's
- ;; "static" variables.
- (let ((sym (make-symbol "base-index")))
- `(progn
- (defvar ,sym)
- (unless (boundp ',sym)
- (let ((i 1))
- (while (not (eq (indirect-function (nth 1 (backtrace-frame i)) t)
- (indirect-function 'called-interactively-p)))
- (setq i (1+ i)))
- (setq ,sym i)))
- ;; (unless (eq (nth 1 (backtrace-frame ,sym)) 'called-interactively-p)
- ;; (error "called-interactively-p: %s is out-of-sync!" ,sym))
- (backtrace-frame (+ ,sym ,n)))))
+(defconst internal--call-interactively (symbol-function 'call-interactively))
(defun called-interactively-p (&optional kind)
"Return t if the containing function was called by `call-interactively'.
(get-next-frame
(lambda ()
(setq frame nextframe)
- (setq nextframe (internal--called-interactively-p--get-frame i))
+ (setq nextframe (backtrace-frame i 'called-interactively-p))
;; (message "Frame %d = %S" i nextframe)
(setq i (1+ i)))))
(funcall get-next-frame) ;; Get the first frame.
(pcase (cons frame nextframe)
;; No subr calls `interactive-p', so we can rule that out.
(`((,_ ,(pred (lambda (f) (subrp (indirect-function f)))) . ,_) . ,_) nil)
- ;; Somehow, I sometimes got `command-execute' rather than
- ;; `call-interactively' on my stacktrace !?
- ;;(`(,_ . (t command-execute . ,_)) t)
+ ;; In case #<subr call-interactively> without going through the
+ ;; `call-interactively' symbol (bug#3984).
+ (`(,_ . (t ,(pred (eq internal--call-interactively)) . ,_)) t)
(`(,_ . (t call-interactively . ,_)) t)))))
(defun interactive-p ()
(declare (obsolete called-interactively-p "23.2"))
(called-interactively-p 'interactive))
-(defun function-arity (f &optional num)
- "Return the (MIN . MAX) arity of F.
-If the maximum arity is infinite, MAX is `many'.
-F can be a function or a macro.
-If NUM is non-nil, return non-nil iff F can be called with NUM args."
- (if (symbolp f) (setq f (indirect-function f)))
- (if (eq (car-safe f) 'macro) (setq f (cdr f)))
- (let ((res
- (if (subrp f)
- (let ((x (subr-arity f)))
- (if (eq (cdr x) 'unevalled) (cons (car x) 'many)))
- (let* ((args (if (consp f) (cadr f) (aref f 0)))
- (max (length args))
- (opt (memq '&optional args))
- (rest (memq '&rest args))
- (min (- max (length opt))))
- (if opt
- (cons min (if rest 'many (1- max)))
- (if rest
- (cons (- max (length rest)) 'many)
- (cons min max)))))))
- (if (not num)
- res
- (and (>= num (car res))
- (or (eq 'many (cdr res)) (<= num (cdr res)))))))
-
-(defun set-temporary-overlay-map (map &optional keep-pred)
+(defun internal-push-keymap (keymap symbol)
+ (let ((map (symbol-value symbol)))
+ (unless (memq keymap map)
+ (unless (memq 'add-keymap-witness (symbol-value symbol))
+ (setq map (make-composed-keymap nil (symbol-value symbol)))
+ (push 'add-keymap-witness (cdr map))
+ (set symbol map))
+ (push keymap (cdr map)))))
+
+(defun internal-pop-keymap (keymap symbol)
+ (let ((map (symbol-value symbol)))
+ (when (memq keymap map)
+ (setf (cdr map) (delq keymap (cdr map))))
+ (let ((tail (cddr map)))
+ (and (or (null tail) (keymapp tail))
+ (eq 'add-keymap-witness (nth 1 map))
+ (set symbol tail)))))
+
+(defun set-temporary-overlay-map (map &optional keep-pred on-exit)
"Set MAP as a temporary keymap taking precedence over most other keymaps.
Note that this does NOT take precedence over the \"overriding\" maps
`overriding-terminal-local-map' and `overriding-local-map' (or the
Normally, MAP is used only once. If the optional argument
KEEP-PRED is t, MAP stays active if a key from MAP is used.
KEEP-PRED can also be a function of no arguments: if it returns
-non-nil then MAP stays active."
- (let* ((clearfunsym (make-symbol "clear-temporary-overlay-map"))
- (overlaysym (make-symbol "t"))
- (alist (list (cons overlaysym map)))
- (clearfun
- ;; FIXME: Use lexical-binding.
- `(lambda ()
- (unless ,(cond ((null keep-pred) nil)
+non-nil then MAP stays active.
+
+Optional ON-EXIT argument is a function that is called after the
+deactivation of MAP."
+ (let ((clearfun (make-symbol "clear-temporary-overlay-map")))
+ ;; Don't use letrec, because equal (in add/remove-hook) would get trapped
+ ;; in a cycle.
+ (fset clearfun
+ (lambda ()
+ ;; FIXME: Handle the case of multiple temporary-overlay-maps
+ ;; E.g. if isearch and C-u both use temporary-overlay-maps, Then
+ ;; the lifetime of the C-u should be nested within the isearch
+ ;; overlay, so the pre-command-hook of isearch should be
+ ;; suspended during the C-u one so we don't exit isearch just
+ ;; because we hit 1 after C-u and that 1 exits isearch whereas it
+ ;; doesn't exit C-u.
+ (with-demoted-errors "set-temporary-overlay-map PCH: %S"
+ (unless (cond ((null keep-pred) nil)
((eq t keep-pred)
- `(eq this-command
- (lookup-key ',map
- (this-command-keys-vector))))
- (t `(funcall ',keep-pred)))
- (set ',overlaysym nil) ;Just in case.
- (remove-hook 'pre-command-hook ',clearfunsym)
- (setq emulation-mode-map-alists
- (delq ',alist emulation-mode-map-alists))))))
- (set overlaysym overlaysym)
- (fset clearfunsym clearfun)
- (add-hook 'pre-command-hook clearfunsym)
- ;; FIXME: That's the keymaps with highest precedence, except for
- ;; the `keymap' text-property ;-(
- (push alist emulation-mode-map-alists)))
+ (eq this-command
+ (lookup-key map (this-command-keys-vector))))
+ (t (funcall keep-pred)))
+ (internal-pop-keymap map 'overriding-terminal-local-map)
+ (remove-hook 'pre-command-hook clearfun)
+ (when on-exit (funcall on-exit))))))
+ (add-hook 'pre-command-hook clearfun)
+ (internal-push-keymap map 'overriding-terminal-local-map)))
;;;; Progress reporters.
nil ,@(cdr (cdr spec)))))
\f
-;;;; Support for watching filesystem events.
-
-(defun file-notify-handle-event (event)
- "Handle file system monitoring event.
-If EVENT is a filewatch event, call its callback.
-Otherwise, signal a `filewatch-error'."
- (interactive "e")
- (if (and (eq (car event) 'file-notify)
- (>= (length event) 3))
- (funcall (nth 2 event) (nth 1 event))
- (signal 'filewatch-error
- (cons "Not a valid file-notify event" event))))
-
-\f
;;;; Comparing version strings.
(defconst version-separator "."