diff options
Diffstat (limited to 'lisp/subr.el')
| -rw-r--r-- | lisp/subr.el | 170 |
1 files changed, 118 insertions, 52 deletions
diff --git a/lisp/subr.el b/lisp/subr.el index a48038fa12b..68cd230c5e2 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -169,7 +169,8 @@ change the list." ;; 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))))))) + (macroexp-let2 macroexp-copyable-p x getter + `(prog1 ,x ,(funcall setter `(cdr ,x)))))))) (defmacro when (cond &rest body) "If COND yields non-nil, do BODY, else return nil. @@ -265,7 +266,9 @@ 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'." +`defun-declarations-alist' and `macro-declarations-alist'. + +For more information, see info node `(elisp)Declare Form'." ;; FIXME: edebug spec should pay attention to defun-declarations-alist. nil) @@ -332,6 +335,7 @@ Any list whose car is `frame-configuration' is assumed to be a frame configuration." (and (consp object) (eq (car object) 'frame-configuration))) + ;;;; List functions. @@ -380,6 +384,13 @@ If N is omitted or nil, remove the last element." (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. @@ -545,6 +556,15 @@ Elements of ALIST that are not conses are ignored." (setq tail tail-cdr)))) alist) +(defun alist-get (key alist &optional default remove) + "Get the value associated to KEY in ALIST. +DEFAULT is the value to return if KEY is not found in ALIST. +REMOVE, if non-nil, means that when setting this element, we should +remove the entry if the new value is `eql' to DEFAULT." + (ignore remove) ;;Silence byte-compiler. + (let ((x (assq key alist))) + (if x (cdr x) default))) + (defun remove (elt seq) "Return a copy of SEQ with all occurrences of ELT removed. SEQ must be a list, vector, or string. The comparison is done with `equal'." @@ -1999,7 +2019,14 @@ some sort of escape sequence, the ambiguity is resolved via `read-key-delay'." (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)) + (let* ((keys + (catch 'read-key (read-key-sequence-vector prompt nil t))) + (key (aref keys 0))) + (if (and (> (length keys) 1) + (memq key '(mode-line header-line + left-fringe right-fringe))) + (aref keys 1) + key))) (cancel-timer timer) (use-global-map old-global-map)))) @@ -2018,7 +2045,7 @@ If optional CONFIRM is non-nil, read the password twice to make sure. 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! +You could let-bind `read-hide-char' to another hiding character, though. Once the caller uses the password, it can erase the password by doing (clear-string STRING)." @@ -2043,7 +2070,7 @@ by doing (clear-string STRING)." beg))) (dotimes (i (- end beg)) (put-text-property (+ i beg) (+ 1 i beg) - 'display (string ?.))))) + 'display (string (or read-hide-char ?.)))))) minibuf) (minibuffer-with-setup-hook (lambda () @@ -2057,12 +2084,9 @@ by doing (clear-string STRING)." (setq-local show-paren-mode nil) ;bug#16091. (add-hook 'after-change-functions hide-chars-fun nil 'local)) (unwind-protect - (let ((enable-recursive-minibuffers t)) - (read-string - (if noninteractive - (format "%s[INPUT WILL NOT BE HIDDEN!] " prompt) ; bug#17839 - prompt) - nil t default)) ; t = "no history" + (let ((enable-recursive-minibuffers t) + (read-hide-char (or read-hide-char ?.))) + (read-string 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 @@ -2197,12 +2221,16 @@ floating point support." (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. @@ -2709,14 +2737,6 @@ computing the hash. If BINARY is non-nil, return a string in binary form." (secure-hash 'sha1 object start end binary)) -(defalias 'function-put #'put - ;; This is only really used in Emacs>24.4, but we add it to 24.4 already, so - ;; as to ease the pain when people use future autoload files that contain - ;; function-put. - "Set function F's property PROP to VALUE. -The namespace for PROP is shared with symbols. -So far, F can only be a symbol, not a lambda expression.") - (defun function-get (f prop &optional autoload) "Return the value of property PROP of function F. If AUTOLOAD is non-nil and F is autoloaded, try to autoload it @@ -2952,6 +2972,14 @@ Similar to `call-process-shell-command', but calls `process-file'." ;;;; Lisp macros to do various things temporarily. +(defmacro track-mouse (&rest body) + "Evaluate BODY with mouse movement events enabled. +Within a `track-mouse' form, mouse motion generates input events that + you can read with `read-event'. +Normally, mouse motion is ignored." + (declare (debug t) (indent 0)) + `(internal--track-mouse (lambda () ,@body))) + (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. @@ -3216,12 +3244,7 @@ not really affect the buffer's content." `(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) @@ -3339,6 +3362,19 @@ The value returned is the value of the last form in 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))))) + ;;; Matching and match data. @@ -3690,12 +3726,14 @@ and replace a sub-expression, e.g. (setq matches (cons (substring string start l) matches)) ; leftover (apply #'concat (nreverse matches))))) -(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. @@ -3859,7 +3897,9 @@ This function is called directly from the C code." ;; 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) + (when (save-match-data + (and (string-match "/obsolete/\\([^/]*\\)\\'" abs-file) + (not (equal "loaddefs.el" (match-string 1 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!" @@ -3879,7 +3919,8 @@ This function is called directly from the C code." (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)) @@ -4196,7 +4237,8 @@ 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)) +(defconst internal--funcall-interactively + (symbol-function 'funcall-interactively)) (defun called-interactively-p (&optional kind) "Return t if the containing function was called by `call-interactively'. @@ -4270,10 +4312,13 @@ command is called from a keyboard macro?" (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))))) + ;; In case #<subr funcall-interactively> without going through the + ;; `funcall-interactively' symbol (bug#3984). + (`(,_ . (t ,(pred (lambda (f) + (eq internal--funcall-interactively + (indirect-function f)))) + . ,_)) + t))))) (defun interactive-p () "Return t if the containing function was run directly by user input. @@ -4321,16 +4366,24 @@ use `called-interactively-p'." 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. +function of no arguments: it is called from `pre-command-hook' and +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"))) +lookup sequence then continues. + +This returns an \"exit function\", which can be called with no argument +to deactivate this transient map, regardless of KEEP-PRED." + (let* ((clearfun (make-symbol "clear-transient-map")) + (exitfun + (lambda () + (internal-pop-keymap map 'overriding-terminal-local-map) + (remove-hook 'pre-command-hook clearfun) + (when on-exit (funcall on-exit))))) ;; Don't use letrec, because equal (in add/remove-hook) would get trapped ;; in a cycle. (fset clearfun @@ -4354,11 +4407,10 @@ lookup sequence then continues." (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)))))) + (funcall exitfun))))) (add-hook 'pre-command-hook clearfun) - (internal-push-keymap map 'overriding-terminal-local-map))) + (internal-push-keymap map 'overriding-terminal-local-map) + exitfun)) ;;;; Progress reporters. @@ -4466,11 +4518,10 @@ NEW-MESSAGE, if non-nil, sets a new message for the reporter." (min-value (aref parameters 1)) (max-value (aref parameters 2)) (text (aref parameters 3)) - (current-time (float-time)) (enough-time-passed ;; See if enough time has passed since the last update. (or (not update-time) - (when (>= current-time update-time) + (when (>= (float-time) update-time) ;; Calculate time for the next update (aset parameters 0 (+ update-time (aref parameters 5))))))) (cond ((and min-value max-value) @@ -4770,6 +4821,21 @@ which is higher than \"1alpha\", which is higher than \"1snapshot\". Also, \"-GIT\", \"-CVS\" and \"-NNN\" are treated as snapshot versions." (version-list-= (version-to-list v1) (version-to-list v2))) +(defvar package--builtin-versions + ;; Mostly populated by loaddefs.el via autoload-builtin-package-versions. + (purecopy `((emacs . ,(version-to-list emacs-version)))) + "Alist giving the version of each versioned builtin package. +I.e. each element of the list is of the form (NAME . VERSION) where +NAME is the package name as a symbol, and VERSION is its version +as a list.") + +(defun package--description-file (dir) + (concat (let ((subdir (file-name-nondirectory + (directory-file-name dir)))) + (if (string-match "\\([^.].*?\\)-\\([0-9]+\\(?:[.][0-9]+\\|\\(?:pre\\|beta\\|alpha\\)[0-9]+\\)*\\)" subdir) + (match-string 1 subdir) subdir)) + "-pkg.el")) + ;;; Misc. (defconst menu-bar-separator '("--") |