diff options
Diffstat (limited to 'lisp/subr.el')
| -rw-r--r-- | lisp/subr.el | 223 |
1 files changed, 197 insertions, 26 deletions
diff --git a/lisp/subr.el b/lisp/subr.el index 329c4ca2c24..679aeed876f 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -36,6 +36,42 @@ Each element of this list holds the arguments to one call to `defcustom'.") (setq custom-declare-variable-list (cons arguments custom-declare-variable-list))) +(defmacro declare-function (fn file &optional arglist fileonly) + "Tell the byte-compiler that function FN is defined, in FILE. +Optional ARGLIST is the argument list used by the function. The +FILE argument is not used by the byte-compiler, but by the +`check-declare' package, which checks that FILE contains a +definition for FN. ARGLIST is used by both the byte-compiler and +`check-declare' to check for consistency. + +FILE can be either a Lisp file (in which case the \".el\" +extension is optional), or a C file. C files are expanded +relative to the Emacs \"src/\" directory. Lisp files are +searched for using `locate-library', and if that fails they are +expanded relative to the location of the file containing the +declaration. A FILE with an \"ext:\" prefix is an external file. +`check-declare' will check such files if they are found, and skip +them without error if they are not. + +FILEONLY non-nil means that `check-declare' will only check that +FILE exists, not that it defines FN. This is intended for +function-definitions that `check-declare' does not recognize, e.g. +`defstruct'. + +To specify a value for FILEONLY without passing an argument list, +set ARGLIST to `t'. This is necessary because `nil' means an +empty argument list, rather than an unspecified one. + +Note that for the purposes of `check-declare', this statement +must be the first non-whitespace on a line, and everything up to +the end of FILE must be all on the same line. For example: + +\(declare-function c-end-of-defun \"progmodes/cc-cmds.el\" + \(&optional arg)) + +For more information, see Info node `elisp(Declaring Functions)'." + ;; Does nothing - byte-compile-declare-function does the work. + nil) ;;;; Basic Lisp macros. @@ -510,6 +546,7 @@ Don't call this function; it is for internal use only." (if (integerp b) (< a b) t) (if (integerp b) t + ;; string< also accepts symbols. (string< a b)))))) (dolist (p list) (funcall function (car p) (cdr p)))) @@ -702,7 +739,7 @@ The normal global definition of the character C-x indirects to this keymap.") ;; Filter out integers too large to be events. ;; M is the biggest modifier. (zerop (logand obj (lognot (1- (lsh ?\M-\^@ 1))))) - (char-valid-p (event-basic-type obj))) + (characterp (event-basic-type obj))) (and (symbolp obj) (get obj 'event-symbol-elements)) (and (consp obj) @@ -722,7 +759,9 @@ even when EVENT actually has modifiers." (if (listp type) (setq type (car type))) (if (symbolp type) - (cdr (get type 'event-symbol-elements)) + ;; Don't read event-symbol-elements directly since we're not + ;; sure the symbol has already been parsed. + (cdr (internal-event-symbol-parse-modifiers type)) (let ((list nil) (char (logand type (lognot (logior ?\M-\^@ ?\C-\^@ ?\S-\^@ ?\H-\^@ ?\s-\^@ ?\A-\^@))))) @@ -857,7 +896,8 @@ and `event-end' functions." (x (/ (car pair) (frame-char-width frame))) (y (/ (cdr pair) (+ (frame-char-height frame) (or (frame-parameter frame 'line-spacing) - default-line-spacing + ;; FIXME: Why the `default'? + (default-value 'line-spacing) 0))))) (cons x y)))))) @@ -1063,7 +1103,17 @@ function, it is changed to a list of functions." (append hook-value (list function)) (cons function hook-value)))) ;; Set the actual variable - (if local (set hook hook-value) (set-default hook hook-value)))) + (if local + (progn + ;; If HOOK isn't a permanent local, + ;; but FUNCTION wants to survive a change of modes, + ;; mark HOOK as partially permanent. + (and (symbolp function) + (get function 'permanent-local-hook) + (not (get hook 'permanent-local)) + (put hook 'permanent-local 'permanent-local-hook)) + (set hook hook-value)) + (set-default hook hook-value)))) (defun remove-hook (hook function &optional local) "Remove from the value of HOOK the function FUNCTION. @@ -1218,7 +1268,8 @@ if it is empty or a duplicate." Execution is delayed if `delay-mode-hooks' is non-nil. If `delay-mode-hooks' is nil, run `after-change-major-mode-hook' after running the mode hooks. -Major mode functions should use this." +Major mode functions should use this instead of `run-hooks' when running their +FOO-mode-hook." (if delay-mode-hooks ;; Delaying case. (dolist (hook hooks) @@ -1535,6 +1586,23 @@ FILE should be the name of a library, with no directory name." ;;;; Process stuff. +(defun process-lines (program &rest args) + "Execute PROGRAM with ARGS, returning its output as a list of lines. +Signal an error if the program returns with a non-zero exit status." + (with-temp-buffer + (let ((status (apply 'call-process program nil (current-buffer) nil args))) + (unless (eq status 0) + (error "%s exited with status %s" program status)) + (goto-char (point-min)) + (let (lines) + (while (not (eobp)) + (setq lines (cons (buffer-substring-no-properties + (line-beginning-position) + (line-end-position)) + lines)) + (forward-line 1)) + (nreverse lines))))) + ;; open-network-stream is a wrapper around make-network-process. (when (featurep 'make-network-process) @@ -1626,7 +1694,7 @@ any other non-digit terminates the character code and is then used as input.")) ;; or C-q C-x might not return immediately since ESC or C-x might be ;; bound to some prefix in function-key-map or key-translation-map. (setq translated char) - (let ((translation (lookup-key function-key-map (vector char)))) + (let ((translation (lookup-key local-function-key-map (vector char)))) (if (arrayp translation) (setq translated (aref translation 0)))) (cond ((null translated)) @@ -2046,32 +2114,44 @@ On other systems, this variable is normally always nil.") (put 'cl-assertion-failed 'error-conditions '(error)) (put 'cl-assertion-failed 'error-message "Assertion failed") +(defconst user-emacs-directory + (if (eq system-type 'ms-dos) + ;; MS-DOS cannot have initial dot. + "~/_emacs.d/" + "~/.emacs.d/") + "Directory beneath which additional per-user Emacs-specific files are placed. +Various programs in Emacs store information in this directory. +Note that this should end with a directory separator.") + ;;;; Misc. useful functions. (defun find-tag-default () "Determine default tag to search for, based on text at point. If there is no plausible default, return nil." - (save-excursion - (while (looking-at "\\sw\\|\\s_") - (forward-char 1)) - (if (or (re-search-backward "\\sw\\|\\s_" - (save-excursion (beginning-of-line) (point)) - t) - (re-search-forward "\\(\\sw\\|\\s_\\)+" - (save-excursion (end-of-line) (point)) - t)) - (progn - (goto-char (match-end 0)) - (condition-case nil - (buffer-substring-no-properties - (point) - (progn (forward-sexp -1) - (while (looking-at "\\s'") - (forward-char 1)) - (point))) - (error nil))) - nil))) + (let (from to bound) + (when (or (progn + ;; Look at text around `point'. + (save-excursion + (skip-syntax-backward "w_") (setq from (point))) + (save-excursion + (skip-syntax-forward "w_") (setq to (point))) + (> to from)) + ;; Look between `line-beginning-position' and `point'. + (save-excursion + (and (setq bound (line-beginning-position)) + (skip-syntax-backward "^w_" bound) + (> (setq to (point)) bound) + (skip-syntax-backward "w_") + (setq from (point)))) + ;; Look between `point' and `line-end-position'. + (save-excursion + (and (setq bound (line-end-position)) + (skip-syntax-forward "^w_" bound) + (< (setq from (point)) bound) + (skip-syntax-forward "w_") + (setq to (point))))) + (buffer-substring-no-properties from to)))) (defun play-sound (sound) "SOUND is a list of the form `(sound KEYWORD VALUE...)'. @@ -2094,6 +2174,8 @@ a system-dependent default device name is used." (play-sound-internal sound) (error "This Emacs binary lacks sound support"))) +(declare-function w32-shell-dos-semantics "w32-fns" nil) + (defun shell-quote-argument (argument) "Quote an argument for passing as argument to an inferior shell." (if (or (eq system-type 'ms-dos) @@ -2304,6 +2386,15 @@ Wildcards and redirection are handled as usual in the shell. (start-process name buffer shell-file-name shell-command-switch (mapconcat 'identity args " "))))) +(defun start-file-process-shell-command (name buffer &rest args) + "Start a program in a subprocess. Return the process object for it. +Similar to `start-process-shell-command', but calls `start-file-process'." + (start-file-process + name buffer + (if (file-remote-p default-directory) "/bin/sh" shell-file-name) + (if (file-remote-p default-directory) "-c" shell-command-switch) + (mapconcat 'identity args " "))) + (defun call-process-shell-command (command &optional infile buffer display &rest args) "Execute the shell command COMMAND synchronously in separate process. @@ -2335,6 +2426,16 @@ If you quit, the process is killed with SIGINT, or SIGKILL if you quit again." infile buffer display shell-command-switch (mapconcat 'identity (cons command args) " "))))) + +(defun process-file-shell-command (command &optional infile buffer display + &rest args) + "Process files synchronously in a separate process. +Similar to `call-process-shell-command', but calls `process-file'." + (process-file + (if (file-remote-p default-directory) "/bin/sh" shell-file-name) + infile buffer display + (if (file-remote-p default-directory) "-c" shell-command-switch) + (mapconcat 'identity (cons command args) " "))) ;;;; Lisp macros to do various things temporarily. @@ -2383,6 +2484,23 @@ See also `with-temp-buffer'." (if (window-live-p save-selected-window-window) (select-window save-selected-window-window 'norecord)))))) +(defmacro with-selected-frame (frame &rest body) + "Execute the forms in BODY with FRAME as the selected frame. +The value returned is the value of the last form in BODY. +See also `with-temp-buffer'." + (declare (indent 1) (debug t)) + (let ((old-frame (make-symbol "old-frame")) + (old-buffer (make-symbol "old-buffer"))) + `(let ((,old-frame (selected-frame)) + (,old-buffer (current-buffer))) + (unwind-protect + (progn (select-frame ,frame) + ,@body) + (if (frame-live-p ,old-frame) + (select-frame ,old-frame)) + (if (buffer-live-p ,old-buffer) + (set-buffer ,old-buffer)))))) + (defmacro with-temp-file (file &rest body) "Create a new buffer, evaluate BODY there, and write the buffer to FILE. The value returned is the value of the last form in BODY. @@ -2480,6 +2598,29 @@ If BODY finishes, `while-no-input' returns whatever value BODY produced." (or (input-pending-p) ,@body)))))) +(defmacro condition-case-no-debug (var bodyform &rest handlers) + "Like `condition-case' except that it does not catch anything when debugging. +More specifically if `debug-on-error' is set, then it does not catch any signal." + (declare (debug condition-case) (indent 2)) + (let ((bodysym (make-symbol "body"))) + `(let ((,bodysym (lambda () ,bodyform))) + (if debug-on-error + (funcall ,bodysym) + (condition-case ,var + (funcall ,bodysym) + ,@handlers))))) + +(defmacro with-demoted-errors (&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 signalled." + (declare (debug t) (indent 0)) + (let ((err (make-symbol "err"))) + `(condition-case-no-debug ,err + (progn ,@body) + (error (message "Error: %s" ,err) nil)))) + (defmacro combine-after-change-calls (&rest body) "Execute BODY, but don't call the after-change functions till the end. If BODY makes changes in the buffer, they are recorded @@ -2645,6 +2786,24 @@ STRING should be given if the last search was by `string-match' on STRING." (buffer-substring-no-properties (match-beginning num) (match-end num))))) + +(defun match-substitute-replacement (replacement + &optional fixedcase literal string subexp) + "Return REPLACEMENT as it will be inserted by `replace-match'. +In other words, all back-references in the form `\\&' and `\\N' +are substituted with actual strings matched by the last search. +Optional FIXEDCASE, LITERAL, STRING and SUBEXP have the same +meaning as for `replace-match'." + (let ((match (match-string 0 string))) + (save-match-data + (set-match-data (mapcar (lambda (x) + (if (numberp x) + (- x (match-beginning 0)) + x)) + (match-data t))) + (replace-match replacement fixedcase literal match subexp)))) + + (defun looking-back (regexp &optional limit greedy) "Return non-nil if text before point matches regular expression REGEXP. Like `looking-at' except matches before point, and is slower. @@ -2674,6 +2833,18 @@ of a match for REGEXP." (looking-at (concat "\\(?:" regexp "\\)\\'"))))) (not (null pos)))) +(defsubst looking-at-p (regexp) + "\ +Same as `looking-at' except this function does not change the match data." + (let ((inhibit-changing-match-data t)) + (looking-at regexp))) + +(defsubst string-match-p (regexp string &optional start) + "\ +Same as `string-match' except this function does not change the match data." + (let ((inhibit-changing-match-data t)) + (string-match regexp string start))) + (defun subregexp-context-p (regexp pos &optional start) "Return non-nil if POS is in a normal subregexp context in REGEXP. A subregexp context is one where a sub-regexp can appear. |