X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/42b2a986d9d4b7040fb20c90ec0efeffb78e761a..a3095f422d5a1ba89b7e5f0c3a8826cb9195fb36:/lisp/subr.el diff --git a/lisp/subr.el b/lisp/subr.el index 0166a3276a..73bc1d99e0 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -26,6 +26,9 @@ ;;; 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'.") @@ -112,6 +115,11 @@ It may also be omitted. 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))) @@ -139,29 +147,33 @@ was called." `(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. @@ -184,8 +196,7 @@ value of last one, or nil if there are none. (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. @@ -261,6 +272,7 @@ the return value (nil if RESULT is omitted). "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) )) @@ -520,7 +532,13 @@ side-effects, and the argument LIST is not modified." ;;;; Keymap support. -(defalias 'kbd 'read-kbd-macro) +(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 () @@ -714,7 +732,7 @@ Subkeymaps may be modified but are not canonicalized." (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) @@ -891,17 +909,9 @@ The normal global definition of the character C-x indirects to this keymap.") (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. @@ -1149,6 +1159,7 @@ be a list of the form returned by `event-start' and `event-end'." (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. @@ -1173,6 +1184,7 @@ is converted into a string by expressing it in decimal." (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") ;;;; Obsolescence declarations for variables, and aliases. @@ -1252,16 +1264,6 @@ to reread, so it now uses nil to mean `no event', instead of -1." (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") - ;;;; Alternate names for functions - these are not being phased out. @@ -1689,6 +1691,23 @@ If TOGGLE has a `:menu-tag', that is used for the menu item's label." ;;; 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, @@ -1701,7 +1720,7 @@ TYPE is `defun', `defvar', or `defface', that specifies function 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) @@ -2153,11 +2172,7 @@ by doing (clear-string STRING)." (set (make-local-variable 'post-self-insert-hook) nil) (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 ;; Not sure why but it seems that there might be cases where the @@ -2173,23 +2188,27 @@ by doing (clear-string STRING)." "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.") @@ -2460,7 +2479,8 @@ This finishes the change group by reverting all of its changes." ;;;; 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. @@ -2753,6 +2773,20 @@ computing the hash. If BINARY is non-nil, return a string in binary 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)) ;;;; Support for yanking and text properties. @@ -2998,24 +3032,29 @@ the buffer list ordering." (declare (indent 1) (debug t)) ;; Most of this code is a copy of save-selected-window. `(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 changes not only the - ;; selected-window but also the frame-selected-window of the - ;; destination frame. So we need to save&restore it. + ;; 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) - (window-frame save-selected-window-destination)) - (frame-selected-window - (window-frame save-selected-window-destination))))) + (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 save-selected-window-destination 'norecord) ,@body) ;; First reset frame-selected-window. - (if (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)) + (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))))))