;;; Code:
+;; Beware: while this file has tag `utf-8', before it's compiled, it gets
+;; loaded as "raw-text", so non-ASCII chars won't work right during bootstrap.
+
(defvar custom-declare-variable-list nil
"Record `defcustom' calls made before `custom.el' is loaded to handle them.
Each element of this list holds the arguments to one call to `defcustom'.")
BODY should be a list of Lisp expressions.
\(fn ARGS [DOCSTRING] [INTERACTIVE] BODY)"
+ (declare (doc-string 2) (indent defun)
+ (debug (&define lambda-list
+ [&optional stringp]
+ [&optional ("interactive" interactive)]
+ def-body)))
;; Note that this definition should not use backquotes; subr.el should not
;; depend on backquote.el.
(list 'function (cons 'lambda cdr)))
+(defmacro setq-local (var val)
+ "Set variable VAR to value VAL in current buffer."
+ ;; Can't use backquote here, it's too early in the bootstrap.
+ (list 'set (list 'make-local-variable (list 'quote var)) val))
+
+(defmacro defvar-local (var val &optional docstring)
+ "Define VAR as a buffer-local variable with default value VAL.
+Like `defvar' but additionally marks the variable as being automatically
+buffer-local wherever it is set."
+ (declare (debug defvar) (doc-string 3))
+ ;; Can't use backquote here, it's too early in the bootstrap.
+ (list 'progn (list 'defvar var val docstring)
+ (list 'make-variable-buffer-local (list 'quote var))))
+
(defun apply-partially (fun &rest args)
"Return a function that is a partial application of FUN to ARGS.
ARGS is a list of the first N arguments to pass to FUN.
`(closure (t) (&rest args)
(apply ',fun ,@(mapcar (lambda (arg) `',arg) args) args)))
-(if (null (featurep 'cl))
- (progn
- ;; If we reload subr.el after having loaded CL, be careful not to
- ;; overwrite CL's extended definition of `dolist', `dotimes',
- ;; `declare', `push' and `pop'.
-(defmacro push (newelt listname)
- "Add NEWELT to the list stored in the symbol LISTNAME.
-This is equivalent to (setq LISTNAME (cons NEWELT LISTNAME)).
-LISTNAME must be a symbol."
- (declare (debug (form sexp)))
- (list 'setq listname
- (list 'cons newelt listname)))
-
-(defmacro pop (listname)
- "Return the first element of LISTNAME's value, and remove it from the list.
-LISTNAME must be a symbol whose value is a list.
+(defmacro push (newelt place)
+ "Add NEWELT to the list stored in the generalized variable PLACE.
+This is morally equivalent to (setf PLACE (cons NEWELT PLACE)),
+except that PLACE is only evaluated once (after NEWELT)."
+ (declare (debug (form gv-place)))
+ (if (symbolp place)
+ ;; Important special case, to avoid triggering GV too early in
+ ;; the bootstrap.
+ (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))))))
+
+(defmacro pop (place)
+ "Return the first element of PLACE's value, and remove it from the list.
+PLACE must be a generalized variable whose value is a list.
If the value is nil, `pop' returns nil but does not actually
change the list."
- (declare (debug (sexp)))
+ (declare (debug (gv-place)))
(list 'car
- (list 'prog1 listname
- (list 'setq listname (list 'cdr listname)))))
-))
+ (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.
(if (null (featurep 'cl))
(progn
;; If we reload subr.el after having loaded CL, be careful not to
- ;; overwrite CL's extended definition of `dolist', `dotimes',
- ;; `declare', `push' and `pop'.
+ ;; overwrite CL's extended definition of `dolist', `dotimes', `declare'.
(defmacro dolist (spec &rest body)
"Loop over a list.
"Do not evaluate any arguments and return nil.
Treated as a declaration when used at the right place in a
`defmacro' form. \(See Info anchor `(elisp)Definition of declare'.)"
+ ;; FIXME: edebug spec should pay attention to defun-declarations-alist.
nil)
))
(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'.
+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.
+This is just like `error' except that `user-error's are expected to be the
+result of an incorrect manipulation on the part of the user, rather than the
+result of an actual problem."
+ (while t
+ (signal 'user-error (list (apply #'format format args)))))
+
;; 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)
\f
;;;; Keymap support.
-(defmacro kbd (keys)
+(defun kbd (keys)
"Convert KEYS to the internal Emacs key representation.
KEYS should be a string constant in the format used for
saving keyboard macros (see `edmacro-mode')."
+ ;; Don't use a defalias, since the `pure' property is only true for
+ ;; the calling convention of `kbd'.
(read-kbd-macro keys))
+(put 'kbd 'pure t)
(defun undefined ()
"Beep to tell the user this binding is undefined."
(put 'keyboard-translate-table 'char-table-extra-slots 0)
(defun keyboard-translate (from to)
- "Translate character FROM to TO at a low level.
+ "Translate character FROM to TO on the current terminal.
This function creates a `keyboard-translate-table' if necessary
and then modifies one entry in it."
(or (char-table-p keyboard-translate-table)
(defsubst eventp (obj)
"True if the argument is an event object."
- (or (and (integerp obj)
- ;; FIXME: Why bother?
- ;; Filter out integers too large to be events.
- ;; M is the biggest modifier.
- (zerop (logand obj (lognot (1- (lsh ?\M-\^@ 1)))))
- (characterp (event-basic-type obj)))
- (and (symbolp obj)
- (get obj 'event-symbol-elements))
- (and (consp obj)
- (symbolp (car obj))
- (get (car obj) 'event-symbol-elements))))
+ (or (integerp obj)
+ (and (symbolp obj) obj (not (keywordp obj)))
+ (and (consp obj) (symbolp (car obj)))))
(defun event-modifiers (event)
"Return a list of symbols representing the modifier keys in event EVENT.
(define-obsolete-function-alias 'string-to-int 'string-to-number "22.1")
(make-obsolete 'forward-point "use (+ (point) N) instead." "23.1")
+(make-obsolete 'buffer-has-markers-at nil "24.2")
(defun insert-string (&rest args)
"Mocklisp-compatibility insert function.
(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.2")
\f
;;;; Obsolescence declarations for variables, and aliases.
(make-obsolete-variable 'translation-table-for-input nil "23.1")
(defvaralias 'messages-buffer-max-lines 'message-log-max)
-
-;; These aliases exist in Emacs 19.34, and probably before, but were
-;; only marked as obsolete in 23.1.
-;; The lisp manual (since at least Emacs 21) describes them as
-;; existing "for compatibility with Emacs version 18".
-(define-obsolete-variable-alias 'last-input-char 'last-input-event
- "at least 19.34")
-(define-obsolete-variable-alias 'last-command-char 'last-command-event
- "at least 19.34")
-
\f
;;;; Alternate names for functions - these are not being phased out.
\f
;;; Load history
+(defsubst autoloadp (object)
+ "Non-nil if OBJECT is an autoload."
+ (eq 'autoload (car-safe object)))
+
+;; (defun autoload-type (object)
+;; "Returns the type of OBJECT or `function' or `command' if the type is nil.
+;; OBJECT should be an autoload object."
+;; (when (autoloadp object)
+;; (let ((type (nth 3 object)))
+;; (cond ((null type) (if (nth 2 object) 'command 'function))
+;; ((eq 'keymap t) 'macro)
+;; (type)))))
+
+;; (defalias 'autoload-file #'cadr
+;; "Return the name of the file from which AUTOLOAD will be loaded.
+;; \n\(fn AUTOLOAD)")
+
(defun symbol-file (symbol &optional type)
"Return the name of the file that defined SYMBOL.
The value is normally an absolute file name. It can also be nil,
definition, variable definition, or face definition only."
(if (and (or (null type) (eq type 'defun))
(symbolp symbol) (fboundp symbol)
- (eq 'autoload (car-safe (symbol-function symbol))))
+ (autoloadp (symbol-function symbol)))
(nth 1 (symbol-function symbol))
(let ((files load-history)
file)
(let ((map (make-sparse-keymap)))
;; Don't hide the menu-bar and tool-bar entries.
(define-key map [menu-bar] (lookup-key global-map [menu-bar]))
- (define-key map [tool-bar] (lookup-key global-map [tool-bar]))
+ (define-key map [tool-bar]
+ ;; This hack avoids evaluating the :filter (Bug#9922).
+ (or (cdr (assq 'tool-bar global-map))
+ (lookup-key global-map [tool-bar])))
map))
(aref (catch 'read-key (read-key-sequence-vector prompt nil t)) 0))
(cancel-timer timer)
(message "Password not repeated accurately; please start over")
(sit-for 1))))
success)
- (let (minibuf)
+ (let ((hide-chars-fun
+ (lambda (beg end _len)
+ (clear-this-command-keys)
+ (setq beg (min end (max (minibuffer-prompt-end)
+ beg)))
+ (dotimes (i (- end beg))
+ (put-text-property (+ i beg) (+ 1 i beg)
+ 'display (string ?.)))))
+ minibuf)
(minibuffer-with-setup-hook
(lambda ()
(setq minibuf (current-buffer))
;; Turn off electricity.
(set (make-local-variable 'post-self-insert-hook) nil)
- (add-hook 'after-change-functions
- (lambda (beg end _len)
- (clear-this-command-keys)
- (setq beg (min end (max (minibuffer-prompt-end)
- beg)))
- (dotimes (i (- end beg))
- (put-text-property (+ i beg) (+ 1 i beg)
- 'display (string ?.))))
- nil t))
+ (add-hook 'after-change-functions hide-chars-fun nil 'local))
(unwind-protect
- (read-string prompt nil
- (let ((sym (make-symbol "forget-history")))
- (set sym nil)
- sym)
- default)
+ (read-string prompt nil t default) ; t = "no history"
(when (buffer-live-p minibuf)
- (with-current-buffer minibuf (erase-buffer))))))))
+ (with-current-buffer minibuf
+ ;; Not sure why but it seems that there might be cases where the
+ ;; minibuffer is not always properly reset later on, so undo
+ ;; whatever we've done here (bug#11392).
+ (remove-hook 'after-change-functions hide-chars-fun 'local)
+ (kill-local-variable 'post-self-insert-hook)
+ ;; And of course, don't keep the sensitive data around.
+ (erase-buffer))))))))
;; This should be used by `call-interactively' for `n' specs.
(defun read-number (prompt &optional default)
"Read a numeric value in the minibuffer, prompting with PROMPT.
DEFAULT specifies a default value to return if the user just types RET.
The value of DEFAULT is inserted into PROMPT."
- (let ((n nil))
- (when default
+ (let ((n nil)
+ (default1 (if (consp default) (car default) default)))
+ (when default1
(setq prompt
(if (string-match "\\(\\):[ \t]*\\'" prompt)
- (replace-match (format " (default %s)" default) t t prompt 1)
+ (replace-match (format " (default %s)" default1) t t prompt 1)
(replace-regexp-in-string "[ \t]*\\'"
- (format " (default %s) " default)
+ (format " (default %s) " default1)
prompt t t))))
(while
(progn
- (let ((str (read-from-minibuffer prompt nil nil nil nil
- (and default
- (number-to-string default)))))
+ (let ((str (read-from-minibuffer
+ prompt nil nil nil nil
+ (when default
+ (if (consp default)
+ (mapcar 'number-to-string (delq nil default))
+ (number-to-string default))))))
(condition-case nil
(setq n (cond
- ((zerop (length str)) default)
- ((stringp str) (read str))))
+ ((zerop (length str)) default1)
+ ((stringp str) (string-to-number str))))
(error nil)))
(unless (numberp n)
(message "Please enter a number.")
This finishes the change group by accepting its changes as final."
(dolist (elt handle)
(with-current-buffer (car elt)
- (if (eq elt t)
+ (if (eq (cdr elt) t)
(setq buffer-undo-list t)))))
(defun cancel-change-group (handle)
;;;; Display-related functions.
;; For compatibility.
-(defalias 'redraw-modeline 'force-mode-line-update)
+(define-obsolete-function-alias 'redraw-modeline
+ 'force-mode-line-update "24.2")
(defun force-mode-line-update (&optional all)
"Force redisplay of the current buffer's mode line and header line.
form."
(secure-hash 'sha1 object start end binary))
+(defun function-get (f prop &optional autoload)
+ "Return the value of property PROP of function F.
+If AUTOLOAD is non-nil and F is an autoloaded macro, try to autoload
+the macro in the hope that it will set PROP."
+ (let ((val nil))
+ (while (and (symbolp f)
+ (null (setq val (get f prop)))
+ (fboundp f))
+ (let ((fundef (symbol-function f)))
+ (if (and autoload (autoloadp fundef)
+ (not (equal fundef (autoload-do-load fundef f 'macro))))
+ nil ;Re-try `get' on the same `f'.
+ (setq f fundef))))
+ val))
\f
;;;; Support for yanking and text properties.
the buffer list ordering."
(declare (indent 1) (debug t))
;; Most of this code is a copy of save-selected-window.
- `(let ((save-selected-window-window (selected-window))
- ;; It is necessary to save all of these, because calling
- ;; select-window changes frame-selected-window for whatever
- ;; frame that window is in.
- (save-selected-window-alist
- (mapcar (lambda (frame) (list frame (frame-selected-window frame)))
- (frame-list))))
+ `(let* ((save-selected-window-destination ,window)
+ (save-selected-window-frame
+ (window-frame save-selected-window-destination))
+ (save-selected-window-window (selected-window))
+ ;; Selecting a window on another frame also changes that
+ ;; frame's frame-selected-window. We must save&restore it.
+ (save-selected-window-other-frame
+ (unless (eq (selected-frame) save-selected-window-frame)
+ (frame-selected-window save-selected-window-frame)))
+ (save-selected-window-top-frame
+ (unless (eq (selected-frame) save-selected-window-frame)
+ (tty-top-frame save-selected-window-frame))))
(save-current-buffer
(unwind-protect
- (progn (select-window ,window 'norecord)
+ (progn (select-window save-selected-window-destination 'norecord)
,@body)
- (dolist (elt save-selected-window-alist)
- (and (frame-live-p (car elt))
- (window-live-p (cadr elt))
- (set-frame-selected-window (car elt) (cadr elt) 'norecord)))
+ ;; First reset frame-selected-window.
+ (when (window-live-p save-selected-window-other-frame)
+ ;; We don't use set-frame-selected-window because it does not
+ ;; pass the `norecord' argument to Fselect_window.
+ (select-window save-selected-window-other-frame 'norecord)
+ (and (frame-live-p save-selected-window-top-frame)
+ (not (eq (tty-top-frame) save-selected-window-top-frame))
+ (select-frame save-selected-window-top-frame 'norecord)))
+ ;; Then reset the actual selected-window.
(when (window-live-p save-selected-window-window)
(select-window save-selected-window-window 'norecord))))))
(put symbol 'abortfunc (or abortfunc 'kill-buffer))
(put symbol 'hookvar (or hookvar 'mail-send-hook)))
\f
+(defun set-temporary-overlay-map (map &optional keep-pred)
+ (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)
+ ((eq t keep-pred)
+ `(eq this-command
+ (lookup-key ',map
+ (this-command-keys-vector))))
+ (t `(funcall ',keep-pred)))
+ (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)))
+
;;;; Progress reporters.
;; Progress reporter has the following structure: