\f
;;;; Basic Lisp macros.
-(defalias 'not 'null)
-
(defmacro noreturn (form)
"Evaluate FORM, expecting it not to return.
If FORM does return, signal an error."
(list 'setq place
(list 'cons newelt place))
(require 'macroexp)
- (macroexp-let2 macroexp-copyable-p v newelt
- (gv-letplace (getter setter) place
- (funcall setter `(cons ,v ,getter))))))
+ (require 'gv)
+ (eval `(let ((newelt ',newelt)
+ (place ',place))
+ (macroexp-let2 macroexp-copyable-p v newelt
+ (gv-letplace (getter setter) place
+ (funcall setter (list 'cons v getter))))))))
(defmacro pop (place)
"Return the first element of PLACE's value, and remove it from the list.
,(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)))))))
+ (require 'gv)
+ (eval `(let ((place ',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.
(declare (indent 1) (debug t))
(cons 'if (cons cond (cons nil body))))
-(defmacro dolist (spec &rest body)
- "Loop over a list.
-Evaluate BODY with VAR bound to each car from LIST, in turn.
-Then evaluate RESULT to get return value, default nil.
-
-\(fn (VAR LIST [RESULT]) BODY...)"
- (declare (indent 1) (debug ((symbolp form &optional form) body)))
- ;; It would be cleaner to create an uninterned symbol,
- ;; but that uses a lot more space when many functions in many files
- ;; use dolist.
- ;; FIXME: This cost disappears in byte-compiled lexical-binding files.
- (let ((temp '--dolist-tail--))
- ;; This is not a reliable test, but it does not matter because both
- ;; semantics are acceptable, tho one is slightly faster with dynamic
- ;; scoping and the other is slightly faster (and has cleaner semantics)
- ;; with lexical scoping.
- (if lexical-binding
- `(let ((,temp ,(nth 1 spec)))
- (while ,temp
- (let ((,(car spec) (car ,temp)))
- ,@body
- (setq ,temp (cdr ,temp))))
- ,@(cdr (cdr spec)))
- `(let ((,temp ,(nth 1 spec))
- ,(car spec))
- (while ,temp
- (setq ,(car spec) (car ,temp))
- ,@body
- (setq ,temp (cdr ,temp)))
- ,@(if (cdr (cdr spec))
- `((setq ,(car spec) nil) ,@(cdr (cdr spec))))))))
-
(defmacro dotimes (spec &rest body)
"Loop a certain number of times.
Evaluate BODY with VAR bound to successive integers running from 0,
(setq ,(car spec) (1+ ,(car spec))))
,@(cdr (cdr spec))))))
-(defmacro declare (&rest _specs)
- "Do not evaluate any arguments, and return nil.
-If a `declare' form appears as the first form in the body of a
-`defun' or `defmacro' form, SPECS specifies various additional
-information about the function or macro; these go into effect
-during the evaluation of the `defun' or `defmacro' form.
-
-The possible values of SPECS are specified by
-`defun-declarations-alist' and `macro-declarations-alist'."
- ;; FIXME: edebug spec should pay attention to defun-declarations-alist.
- nil)
-
(defmacro ignore-errors (&rest body)
"Execute BODY; if an error occurs, return nil.
Otherwise, return result of last form in BODY.
See also `with-demoted-errors' that does something similar
without silencing all errors."
(declare (debug t) (indent 0))
- `(condition-case nil (progn ,@body) (error nil)))
+ `(condition-case nil
+ (%funcall (@ (guile) catch)
+ t
+ #'(lambda () ,@body)
+ #'(lambda (&rest args) nil))
+ (error nil)))
\f
;;;; Basic Lisp functions.
configuration."
(and (consp object)
(eq (car object) 'frame-configuration)))
+
\f
;;;; List functions.
(if (> n 0) (setcdr (nthcdr (- (1- m) n) list) nil))
list))))
+(defun zerop (number)
+ "Return t if NUMBER is zero."
+ ;; Used to be in C, but it's pointless since (= 0 n) is faster anyway because
+ ;; = has a byte-code.
+ (declare (compiler-macro (lambda (_) `(= 0 ,number))))
+ (= 0 number))
+
(defun delete-dups (list)
"Destructively remove `equal' duplicates from LIST.
Store the result in LIST and return it. LIST must be a proper list.
(declare-function scroll-bar-scale "scroll-bar" (num-denom whole))
+(defmacro with-current-buffer (buffer-or-name &rest body)
+ "Execute the forms in BODY with BUFFER-OR-NAME temporarily current.
+BUFFER-OR-NAME must be a buffer or the name of an existing buffer.
+The value returned is the value of the last form in BODY. See
+also `with-temp-buffer'."
+ (declare (indent 1) (debug t))
+ `(save-current-buffer
+ (set-buffer ,buffer-or-name)
+ ,@body))
+
(defun posn-col-row (position)
"Return the nominal column and row in POSITION, measured in characters.
The column and row values are approximations calculated from the x
and y coordinates in POSITION and the frame's default character width
-and height.
+and default line height, including spacing.
For a scroll-bar event, the result column is 0, and the row
corresponds to the vertical position of the click in the scroll bar.
POSITION should be a list of the form returned by the `event-start'
(make-obsolete 'unfocus-frame "it does nothing." "22.1")
(make-obsolete 'make-variable-frame-local
"explicitly check for a frame-parameter instead." "22.2")
-(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 'redirect-frame-focus '(frame focus-frame) "24.3")
(set-advertised-calling-convention 'decode-char '(ch charset) "21.4")
file))
\f
+(defmacro with-temp-buffer (&rest body)
+ "Create a temporary buffer, and evaluate BODY there like `progn'.
+See also `with-temp-file' and `with-output-to-string'."
+ (declare (indent 0) (debug t))
+ (let ((temp-buffer (make-symbol "temp-buffer")))
+ `(let ((,temp-buffer (generate-new-buffer " *temp*")))
+ ;; FIXME: kill-buffer can change current-buffer in some odd cases.
+ (with-current-buffer ,temp-buffer
+ (unwind-protect
+ (progn ,@body)
+ (and (buffer-name ,temp-buffer)
+ (kill-buffer ,temp-buffer)))))))
+
;;;; Process stuff.
(defun process-lines (program &rest args)
(cancel-timer timer)
(use-global-map old-global-map))))
+(defmacro minibuffer-with-setup-hook (fun &rest body)
+ "Temporarily add FUN to `minibuffer-setup-hook' while executing BODY.
+BODY should use the minibuffer at most once.
+Recursive uses of the minibuffer are unaffected (FUN is not
+called additional times).
+
+This macro actually adds an auxiliary function that calls FUN,
+rather than FUN itself, to `minibuffer-setup-hook'."
+ (declare (indent 1) (debug t))
+ (let ((hook (make-symbol "setup-hook"))
+ (funsym (make-symbol "fun")))
+ `(let ((,funsym ,fun)
+ ,hook)
+ (setq ,hook
+ (lambda ()
+ ;; Clear out this hook so it does not interfere
+ ;; with any recursive minibuffer usage.
+ (remove-hook 'minibuffer-setup-hook ,hook)
+ (funcall ,funsym)))
+ (unwind-protect
+ (progn
+ (add-hook 'minibuffer-setup-hook ,hook)
+ ,@body)
+ (remove-hook 'minibuffer-setup-hook ,hook)))))
+
+(defmacro save-window-excursion (&rest body)
+ "Execute BODY, then restore previous window configuration.
+This macro saves the window configuration on the selected frame,
+executes BODY, then calls `set-window-configuration' to restore
+the saved window configuration. The return value is the last
+form in BODY. The window configuration is also restored if BODY
+exits nonlocally.
+
+BEWARE: Most uses of this macro introduce bugs.
+E.g. it should not be used to try and prevent some code from opening
+a new window, since that window may sometimes appear in another frame,
+in which case `save-window-excursion' cannot help."
+ (declare (indent 0) (debug t))
+ (let ((c (make-symbol "wconfig")))
+ `(let ((,c (current-window-configuration)))
+ (unwind-protect (progn ,@body)
+ (set-window-configuration ,c)))))
+
(defvar read-passwd-map
;; BEWARE: `defconst' would purecopy it, breaking the sharing with
;; minibuffer-local-map along the way!
Optional DEFAULT is a default password to use instead of empty input.
This function echoes `.' for each character that the user types.
+Note that in batch mode, the input is not hidden!
Once the caller uses the password, it can erase the password
by doing (clear-string STRING)."
(add-hook 'after-change-functions hide-chars-fun nil 'local))
(unwind-protect
(let ((enable-recursive-minibuffers t))
- (read-string prompt nil t default)) ; t = "no history"
+ (read-string
+ (if noninteractive
+ (format "%s[INPUT WILL NOT BE HIDDEN!] " prompt) ; bug#17839
+ prompt)
+ nil t default)) ; t = "no history"
(when (buffer-live-p minibuf)
(with-current-buffer minibuf
;; Not sure why but it seems that there might be cases where the
in milliseconds; this was useful when Emacs was built without
floating point support."
(declare (advertised-calling-convention (seconds &optional nodisp) "22.1"))
+ ;; This used to be implemented in C until the following discussion:
+ ;; http://lists.gnu.org/archive/html/emacs-devel/2006-07/msg00401.html
+ ;; Then it was moved to C using an implementation based on an idle timer,
+ ;; which was then replaced by the use of read-event.
(if (numberp nodisp)
(setq seconds (+ seconds (* 1e-3 nodisp))
nodisp obsolete)
;; 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)))
+ ;; For bug#14782, we need read-event to do the keyboard-coding-system
+ ;; decoding (hence non-nil as second arg under POSIX ttys).
+ ;; For bug#15614, we need read-event not to inherit-input-method.
+ ;; So we temporarily suspend input-method-function.
+ (let ((read (let ((input-method-function nil))
+ (read-event nil t seconds))))
(or (null read)
(progn
- ;; If last command was a prefix arg, e.g. C-u, push this event onto
- ;; unread-command-events as (t . EVENT) so it will be added to
- ;; this-command-keys by read-key-sequence.
- (if (eq overriding-terminal-local-map universal-argument-map)
- (setq read (cons t read)))
- (push read unread-command-events)
+ ;; https://lists.gnu.org/archive/html/emacs-devel/2006-10/msg00394.html
+ ;; We want `read' appear in the next command's this-command-event
+ ;; but not in the current one.
+ ;; By pushing (cons t read), we indicate that `read' has not
+ ;; yet been recorded in this-command-keys, so it will be recorded
+ ;; next time it's read.
+ ;; And indeed the `seconds' argument to read-event correctly
+ ;; prevented recording this event in the current command's
+ ;; this-command-keys.
+ (push (cons t read) unread-command-events)
nil))))))
;; Behind display-popup-menus-p test.
\f
;;;; Lisp macros to do various things temporarily.
-(defmacro with-current-buffer (buffer-or-name &rest body)
- "Execute the forms in BODY with BUFFER-OR-NAME temporarily current.
-BUFFER-OR-NAME must be a buffer or the name of an existing buffer.
-The value returned is the value of the last form in BODY. See
-also `with-temp-buffer'."
- (declare (indent 1) (debug t))
- `(save-current-buffer
- (set-buffer ,buffer-or-name)
- ,@body))
-
(defun internal--before-with-selected-window (window)
(let ((other-frame (window-frame window)))
(list window (selected-window)
(when (buffer-live-p ,old-buffer)
(set-buffer ,old-buffer))))))
-(defmacro save-window-excursion (&rest body)
- "Execute BODY, then restore previous window configuration.
-This macro saves the window configuration on the selected frame,
-executes BODY, then calls `set-window-configuration' to restore
-the saved window configuration. The return value is the last
-form in BODY. The window configuration is also restored if BODY
-exits nonlocally.
-
-BEWARE: Most uses of this macro introduce bugs.
-E.g. it should not be used to try and prevent some code from opening
-a new window, since that window may sometimes appear in another frame,
-in which case `save-window-excursion' cannot help."
- (declare (indent 0) (debug t))
- (let ((c (make-symbol "wconfig")))
- `(let ((,c (current-window-configuration)))
- (unwind-protect (progn ,@body)
- (set-window-configuration ,c)))))
-
(defun internal-temp-output-buffer-show (buffer)
"Internal function for `with-output-to-temp-buffer'."
(with-current-buffer buffer
(message "%s" ,current-message)
(message nil)))))))
-(defmacro with-temp-buffer (&rest body)
- "Create a temporary buffer, and evaluate BODY there like `progn'.
-See also `with-temp-file' and `with-output-to-string'."
- (declare (indent 0) (debug t))
- (let ((temp-buffer (make-symbol "temp-buffer")))
- `(let ((,temp-buffer (generate-new-buffer " *temp*")))
- ;; FIXME: kill-buffer can change current-buffer in some odd cases.
- (with-current-buffer ,temp-buffer
- (unwind-protect
- (progn ,@body)
- (and (buffer-name ,temp-buffer)
- (kill-buffer ,temp-buffer)))))))
-
(defmacro with-silent-modifications (&rest body)
"Execute BODY, pretending it does not modify the buffer.
If BODY performs real modifications to the buffer's text, other
`(let* ((,modified (buffer-modified-p))
(buffer-undo-list t)
(inhibit-read-only t)
- (inhibit-modification-hooks t)
- deactivate-mark
- ;; Avoid setting and removing file locks and checking
- ;; buffer's uptodate-ness w.r.t the underlying file.
- buffer-file-name
- buffer-file-truename)
+ (inhibit-modification-hooks t))
(unwind-protect
(progn
,@body)
(prog1 "Error: %S"
(if format (push format body))))))
`(condition-case-unless-debug ,err
- ,(macroexp-progn body)
+ (progn ,@body)
(error (message ,format ,err) nil))))
(defmacro combine-after-change-calls (&rest body)
,@body)
(with-current-buffer ,old-buffer
(set-case-table ,old-case-table))))))
+
+(defmacro with-file-modes (modes &rest body)
+ "Execute BODY with default file permissions temporarily set to MODES.
+MODES is as for `set-default-file-modes'."
+ (declare (indent 1) (debug t))
+ (let ((umask (make-symbol "umask")))
+ `(let ((,umask (default-file-modes)))
+ (unwind-protect
+ (progn
+ (set-default-file-modes ,modes)
+ ,@body)
+ (set-default-file-modes ,umask)))))
+
\f
;;; Matching and match data.
(setq matches (cons (substring string start l) matches)) ; leftover
(apply #'concat (nreverse matches)))))
\f
-(defun string-prefix-p (str1 str2 &optional ignore-case)
- "Return non-nil if STR1 is a prefix of STR2.
+(defun string-prefix-p (prefix string &optional ignore-case)
+ "Return non-nil if PREFIX is a prefix of STRING.
If IGNORE-CASE is non-nil, the comparison is done without paying attention
to case differences."
- (eq t (compare-strings str1 nil nil
- str2 0 (length str1) ignore-case)))
+ (let ((prefix-length (length prefix)))
+ (if (> prefix-length (length string)) nil
+ (eq t (compare-strings prefix 0 prefix-length string
+ 0 prefix-length ignore-case)))))
(defun string-suffix-p (suffix string &optional ignore-case)
"Return non-nil if SUFFIX is a suffix of STRING.
(byte-compile-log-warning msg))
(run-with-timer 0 nil
(lambda (msg)
- (message "%s" msg)) msg))))
+ (message "%s" msg))
+ msg))))
;; Finally, run any other hook.
(run-hook-with-args 'after-load-functions abs-file))
(put symbol 'abortfunc (or abortfunc 'kill-buffer))
(put symbol 'hookvar (or hookvar 'mail-send-hook)))
\f
-(defvar called-interactively-p-functions nil
- "Special hook called to skip special frames in `called-interactively-p'.
-The functions are called with 3 arguments: (I FRAME1 FRAME2),
-where FRAME1 is a \"current frame\", FRAME2 is the next frame,
-I is the index of the frame after FRAME2. It should return nil
-if those frames don't seem special and otherwise, it should return
-the number of frames to skip (minus 1).")
-
-(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'.
-If KIND is `interactive', then only return t if the call was made
-interactively by the user, i.e. not in `noninteractive' mode nor
-when `executing-kbd-macro'.
-If KIND is `any', on the other hand, it will return t for any kind of
-interactive call, including being called as the binding of a key or
-from a keyboard macro, even in `noninteractive' mode.
-
-This function is very brittle, it may fail to return the intended result when
-the code is debugged, advised, or instrumented in some form. Some macros and
-special forms (such as `condition-case') may also sometimes wrap their bodies
-in a `lambda', so any call to `called-interactively-p' from those bodies will
-indicate whether that lambda (rather than the surrounding function) was called
-interactively.
-
-Instead of using this function, it is cleaner and more reliable to give your
-function an extra optional argument whose `interactive' spec specifies
-non-nil unconditionally (\"p\" is a good way to do this), or via
-\(not (or executing-kbd-macro noninteractive)).
-
-The only known proper use of `interactive' for KIND is in deciding
-whether to display a helpful message, or how to display it. If you're
-thinking of using it for any other purpose, it is quite likely that
-you're making a mistake. Think: what do you want to do when the
-command is called from a keyboard macro?"
- (declare (advertised-calling-convention (kind) "23.1"))
- (when (not (and (eq kind 'interactive)
- (or executing-kbd-macro noninteractive)))
- (let* ((i 1) ;; 0 is the called-interactively-p frame.
- frame nextframe
- (get-next-frame
- (lambda ()
- (setq frame nextframe)
- (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.
- (while
- ;; FIXME: The edebug and advice handling should be made modular and
- ;; provided directly by edebug.el and nadvice.el.
- (progn
- ;; frame =(backtrace-frame i-2)
- ;; nextframe=(backtrace-frame i-1)
- (funcall get-next-frame)
- ;; `pcase' would be a fairly good fit here, but it sometimes moves
- ;; branches within local functions, which then messes up the
- ;; `backtrace-frame' data we get,
- (or
- ;; Skip special forms (from non-compiled code).
- (and frame (null (car frame)))
- ;; Skip also `interactive-p' (because we don't want to know if
- ;; interactive-p was called interactively but if it's caller was)
- ;; and `byte-code' (idem; this appears in subexpressions of things
- ;; like condition-case, which are wrapped in a separate bytecode
- ;; chunk).
- ;; FIXME: For lexical-binding code, this is much worse,
- ;; because the frames look like "byte-code -> funcall -> #[...]",
- ;; which is not a reliable signature.
- (memq (nth 1 frame) '(interactive-p 'byte-code))
- ;; Skip package-specific stack-frames.
- (let ((skip (run-hook-with-args-until-success
- 'called-interactively-p-functions
- i frame nextframe)))
- (pcase skip
- (`nil nil)
- (`0 t)
- (_ (setq i (+ i skip -1)) (funcall get-next-frame)))))))
- ;; Now `frame' should be "the function from which we were called".
- (pcase (cons frame nextframe)
- ;; No subr calls `interactive-p', so we can rule that out.
- (`((,_ ,(pred (lambda (f) (subrp (indirect-function f)))) . ,_) . ,_) nil)
- ;; 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 ()
- "Return t if the containing function was run directly by user input.
-This means that the function was called with `call-interactively'
-\(which includes being called as the binding of a key)
-and input is currently coming from the keyboard (not a keyboard macro),
-and Emacs is not running in batch mode (`noninteractive' is nil).
-
-The only known proper use of `interactive-p' is in deciding whether to
-display a helpful message, or how to display it. If you're thinking
-of using it for any other purpose, it is quite likely that you're
-making a mistake. Think: what do you want to do when the command is
-called from a keyboard macro or in batch mode?
-
-To test whether your function was called with `call-interactively',
-either (i) add an extra optional argument and give it an `interactive'
-spec that specifies non-nil unconditionally (such as \"p\"); or (ii)
-use `called-interactively-p'."
- (declare (obsolete called-interactively-p "23.2"))
- (called-interactively-p 'interactive))
-
-(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)))))
-
-(define-obsolete-function-alias
- 'set-temporary-overlay-map 'set-transient-map "24.4")
-
-(defun set-transient-map (map &optional keep-pred on-exit)
- "Set MAP as a temporary keymap taking precedence over other keymaps.
-Normally, MAP is used only once, to look up the very next key.
-However, 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.
-
-Optional arg ON-EXIT, if non-nil, specifies a function that is
-called, with no arguments, after MAP is deactivated.
-
-This uses `overriding-terminal-local-map' which takes precedence over all other
-keymaps. As usual, if no match for a key is found in MAP, the normal key
-lookup sequence then continues."
- (let ((clearfun (make-symbol "clear-transient-map")))
- ;; Don't use letrec, because equal (in add/remove-hook) would get trapped
- ;; in a cycle.
- (fset clearfun
- (lambda ()
- (with-demoted-errors "set-transient-map PCH: %S"
- (unless (cond
- ((not (eq map (cadr overriding-terminal-local-map)))
- ;; There's presumably some other transient-map in
- ;; effect. Wait for that one to terminate before we
- ;; remove ourselves.
- ;; For example, if isearch and C-u both use transient
- ;; maps, then the lifetime of the C-u should be nested
- ;; within isearch's, 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.
- t)
- ((null keep-pred) nil)
- ((eq t keep-pred)
- (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.
;; Progress reporter has the following structure: