;;; subr.el --- basic lisp subroutines for Emacs
-;; Copyright (C) 1985, 86, 92, 94, 95, 99, 2000 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 86, 92, 94, 95, 99, 2000, 2001, 2002
+;; Free Software Foundation, Inc.
+
+;; Maintainer: FSF
+;; Keywords: internal
;; This file is part of GNU Emacs.
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
+;;; Commentary:
+
;;; Code:
(defvar custom-declare-variable-list nil
"Record `defcustom' calls made before `custom.el' is loaded to handle them.
(defun custom-declare-variable-early (&rest arguments)
(setq custom-declare-variable-list
(cons arguments custom-declare-variable-list)))
+
+\f
+(defun macro-declaration-function (macro decl)
+ "Process a declaration found in a macro definition.
+This is set as the value of the variable `macro-declaration-function'.
+MACRO is the name of the macro being defined.
+DECL is a list `(declare ...)' containing the declarations.
+The return value of this function is not used."
+ (dolist (d (cdr decl))
+ (cond ((and (consp d) (eq (car d) 'indent))
+ (put macro 'lisp-indent-function (cadr d)))
+ ((and (consp d) (eq (car d) 'debug))
+ (put macro 'edebug-form-spec (cadr d)))
+ (t
+ (message "Unknown declaration %s" d)))))
+
+(setq macro-declaration-function 'macro-declaration-function)
+
\f
;;;; Lisp language features.
+(defalias 'not 'null)
+
(defmacro lambda (&rest cdr)
"Return a lambda expression.
A call of the form (lambda ARGS DOCSTRING INTERACTIVE BODY) is
(setq m (1+ m) p (cdr p)))
(if (<= n 0) p
(if (< n m) (nthcdr (- m n) x) x)))
- (while (cdr x)
+ (while (consp (cdr x))
(setq x (cdr x)))
x))
+(defun butlast (x &optional n)
+ "Returns a copy of LIST with the last N elements removed."
+ (if (and n (<= n 0)) x
+ (nbutlast (copy-sequence x) n)))
+
+(defun nbutlast (x &optional n)
+ "Modifies LIST to remove the last N elements."
+ (let ((m (length x)))
+ (or n (setq n 1))
+ (and (< n m)
+ (progn
+ (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
+ x))))
+
(defun remove (elt seq)
- "Return a copy of SEQ with all occurences of ELT removed.
+ "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'."
(if (nlistp seq)
;; If SEQ isn't a list, there's no need to copy SEQ because
(delq elt (copy-sequence list))
list))
+(defun copy-tree (tree &optional vecp)
+ "Make a copy of TREE.
+If TREE is a cons cell, this recursively copies both its car and its cdr.
+Contrast to `copy-sequence', which copies only along the cdrs. With second
+argument VECP, this copies vectors as well as conses."
+ (if (consp tree)
+ (let (result)
+ (while (consp tree)
+ (let ((newcar (car tree)))
+ (if (or (consp (car tree)) (and vecp (vectorp (car tree))))
+ (setq newcar (copy-tree (car tree) vecp)))
+ (push newcar result))
+ (setq tree (cdr tree)))
+ (nconc (nreverse result) tree))
+ (if (and vecp (vectorp tree))
+ (let ((i (length (setq tree (copy-sequence tree)))))
+ (while (>= (setq i (1- i)) 0)
+ (aset tree i (copy-tree (aref tree i) vecp)))
+ tree)
+ tree)))
+
(defun assoc-default (key alist &optional test default)
"Find object KEY in a pseudo-alist ALIST.
ALIST is a list of conses or objects. Each element (or the element's car,
(defun member-ignore-case (elt list)
"Like `member', but ignores differences in case and text representation.
ELT must be a string. Upper-case and lower-case letters are treated as equal.
-Unibyte strings are converted to multibyte for comparison."
- (let (element)
- (while (and list (not element))
- (if (eq t (compare-strings elt 0 nil (car list) 0 nil t))
- (setq element (car list)))
- (setq list (cdr list)))
- element))
+Unibyte strings are converted to multibyte for comparison.
+Non-strings in LIST are ignored."
+ (while (and list
+ (not (and (stringp (car list))
+ (eq t (compare-strings elt 0 nil (car list) 0 nil t)))))
+ (setq list (cdr list)))
+ list)
\f
;;;; Keymap support.
"Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF.
In other words, OLDDEF is replaced with NEWDEF where ever it appears.
Alternatively, if optional fourth argument OLDMAP is specified, we redefine
-in KEYMAP as NEWDEF those chars which are defined as OLDDEF in OLDMAP."
+in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP."
;; Don't document PREFIX in the doc string because we don't want to
;; advertise it. It's meant for recursive calls only. Here's its
;; meaning
\(like DEFINITION).
If AFTER is t or omitted, the new binding goes at the end of the keymap.
-
-KEY must contain just one event type--that is to say, it must be a
-string or vector of length 1, but AFTER should be a single event
-type--a symbol or a character, not a sequence.
+AFTER should be a single event type--a symbol or a character, not a sequence.
Bindings are always added before any inherited map.
(unless after (setq after t))
(or (keymapp keymap)
(signal 'wrong-type-argument (list 'keymapp keymap)))
- (if (> (length key) 1)
- (error "multi-event key specified in `define-key-after'"))
- (let ((tail keymap) done inserted
- (first (aref key 0)))
+ (setq key
+ (if (<= (length key) 1) (aref key 0)
+ (setq keymap (lookup-key keymap
+ (apply 'vector
+ (butlast (mapcar 'identity key)))))
+ (aref key (1- (length key)))))
+ (let ((tail keymap) done inserted)
(while (and (not done) tail)
;; Delete any earlier bindings for the same key.
- (if (eq (car-safe (car (cdr tail))) first)
+ (if (eq (car-safe (car (cdr tail))) key)
(setcdr tail (cdr (cdr tail))))
+ ;; If we hit an included map, go down that one.
+ (if (keymapp (car tail)) (setq tail (car tail)))
;; When we reach AFTER's binding, insert the new binding after.
;; If we reach an inherited keymap, insert just before that.
;; If we reach the end of this keymap, insert at the end.
(setq done t))
;; Don't insert more than once.
(or inserted
- (setcdr tail (cons (cons (aref key 0) definition) (cdr tail))))
+ (setcdr tail (cons (cons key definition) (cdr tail))))
(setq inserted t)))
(setq tail (cdr tail)))))
+
(defmacro kbd (keys)
"Convert KEYS to the internal Emacs key representation.
KEYS should be a string constant in the format used for
The normal global definition of the character C-x indirects to this keymap.")
(defvar ctl-x-4-map (make-sparse-keymap)
- "Keymap for subcommands of C-x 4")
+ "Keymap for subcommands of C-x 4.")
(defalias 'ctl-x-4-prefix ctl-x-4-map)
(define-key ctl-x-map "4" 'ctl-x-4-prefix)
(defun event-basic-type (event)
"Returns the basic type of the given event (all modifiers removed).
-The value is an ASCII printing character (not upper case) or a symbol."
+The value is a printing character (not upper case) or a symbol."
(if (consp event)
(setq event (car event)))
(if (symbolp event)
(make-obsolete 'sref 'aref "20.4")
(make-obsolete 'char-bytes "Now this function always returns 1" "20.4")
+(defun insert-string (&rest args)
+ "Mocklisp-compatibility insert function.
+Like the function `insert' except that any argument that is a number
+is converted into a string by expressing it in decimal."
+ (dolist (el args)
+ (insert (if (integerp el) (number-to-string el) el))))
+
+(make-obsolete 'insert-string 'insert "21.3")
+
;; Some programs still use this as a function.
(defun baud-rate ()
"Obsolete function returning the value of the `baud-rate' variable.
(defalias 'string= 'string-equal)
(defalias 'string< 'string-lessp)
(defalias 'move-marker 'set-marker)
-(defalias 'not 'null)
(defalias 'rplaca 'setcar)
(defalias 'rplacd 'setcdr)
(defalias 'beep 'ding) ;preserve lingual purity
"Make the hook HOOK local to the current buffer.
The return value is HOOK.
+You never need to call this function now that `add-hook' does it for you
+if its LOCAL argument is non-nil.
+
When a hook is local, its local and global values
work in concert: running the hook actually runs all the hook
functions listed in *either* the local value *or* the global value
of the hook variable.
-This function works by making `t' a member of the buffer-local value,
+This function works by making t a member of the buffer-local value,
which acts as a flag to run the hook functions in the default value as
well. This works for all normal hooks, but does not work for most
non-normal hooks yet. We will be changing the callers of non-normal
(make-local-variable hook)
(set hook (list t)))
hook)
+(make-obsolete 'make-local-hook "Not necessary any more." "21.1")
(defun add-hook (hook function &optional append local)
"Add to the value of HOOK the function FUNCTION.
The optional fourth argument, LOCAL, if non-nil, says to modify
the hook's buffer-local value rather than its default value.
-This makes the hook buffer-local if needed.
-To make a hook variable buffer-local, always use
-`make-local-hook', not `make-local-variable'.
+This makes the hook buffer-local if needed, and it makes t a member
+of the buffer-local value. That acts as a flag to run the hook
+functions in the default value as well as in the local value.
HOOK should be a symbol, and FUNCTION may be any valid function. If
HOOK is void, it is first set to nil. If HOOK's value is a single
function, it is changed to a list of functions."
(or (boundp hook) (set hook nil))
(or (default-boundp hook) (set-default hook nil))
- (if local (make-local-hook hook)
+ (if local (unless (local-variable-if-set-p hook)
+ (set (make-local-variable hook) (list t)))
;; Detect the case where make-local-variable was used on a hook
;; and do what we used to do.
(unless (and (consp (symbol-value hook)) (memq t (symbol-value hook)))
The optional third argument, LOCAL, if non-nil, says to modify
the hook's buffer-local value rather than its default value.
-This makes the hook buffer-local if needed.
-To make a hook variable buffer-local, always use
-`make-local-hook', not `make-local-variable'."
+This makes the hook buffer-local if needed."
(or (boundp hook) (set hook nil))
(or (default-boundp hook) (set-default hook nil))
- (if local (make-local-hook hook)
+ (if local (unless (local-variable-if-set-p hook)
+ (set (make-local-variable hook) (list t)))
;; Detect the case where make-local-variable was used on a hook
;; and do what we used to do.
(unless (and (consp (symbol-value hook)) (memq t (symbol-value hook)))
;; (not (member (cons 'not function) hook-value)))
;; (push (cons 'not function) hook-value))
;; Set the actual variable
- (if local (set hook hook-value) (set-default hook hook-value))))
+ (if (not local)
+ (set-default hook hook-value)
+ (if (equal hook-value '(t))
+ (kill-local-variable hook)
+ (set hook hook-value)))))
-(defun add-to-list (list-var element)
+(defun add-to-list (list-var element &optional append)
"Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.
The test for presence of ELEMENT is done with `equal'.
-If ELEMENT is added, it is added at the beginning of the list.
+If ELEMENT is added, it is added at the beginning of the list,
+unless the optional argument APPEND is non-nil, in which case
+ELEMENT is added at the end.
+
+The return value is the new value of LIST-VAR.
If you want to use `add-to-list' on a variable that is not defined
until a certain package is loaded, you should put the call to `add-to-list'
other hooks, such as major mode hooks, can do the job."
(if (member element (symbol-value list-var))
(symbol-value list-var)
- (set list-var (cons element (symbol-value list-var)))))
+ (set list-var
+ (if append
+ (append (symbol-value list-var) (list element))
+ (cons element (symbol-value list-var))))))
+
+\f
+;;; Load history
+
+(defvar symbol-file-load-history-loaded nil
+ "Non-nil means we have loaded the file `fns-VERSION.el' in `exec-directory'.
+That file records the part of `load-history' for preloaded files,
+which is cleared out before dumping to make Emacs smaller.")
+
+(defun load-symbol-file-load-history ()
+ "Load the file `fns-VERSION.el' in `exec-directory' if not already done.
+That file records the part of `load-history' for preloaded files,
+which is cleared out before dumping to make Emacs smaller."
+ (unless symbol-file-load-history-loaded
+ (load (expand-file-name
+ ;; fns-XX.YY.ZZ.el does not work on DOS filesystem.
+ (if (eq system-type 'ms-dos)
+ "fns.el"
+ (format "fns-%s.el" emacs-version))
+ exec-directory)
+ ;; The file name fns-%s.el already has a .el extension.
+ nil nil t)
+ (setq symbol-file-load-history-loaded t)))
+
+(defun symbol-file (function)
+ "Return the input source from which FUNCTION was loaded.
+The value is normally a string that was passed to `load':
+either an absolute file name, or a library name
+\(with no directory name and no `.el' or `.elc' at the end).
+It can also be nil, if the definition is not associated with any file."
+ (load-symbol-file-load-history)
+ (let ((files load-history)
+ file functions)
+ (while files
+ (if (memq function (cdr (car files)))
+ (setq file (car (car files)) files nil))
+ (setq files (cdr files)))
+ file))
+
\f
;;;; Specifying things to do after certain files are loaded.
This makes or adds to an entry on `after-load-alist'.
If FILE is already loaded, evaluate FORM right now.
It does nothing if FORM is already on the list for FILE.
-FILE should be the name of a library, with no directory name."
- ;; Make sure there is an element for FILE.
- (or (assoc file after-load-alist)
- (setq after-load-alist (cons (list file) after-load-alist)))
- ;; Add FORM to the element if it isn't there.
+FILE must match exactly. Normally FILE is the name of a library,
+with no directory or extension specified, since that is how `load'
+is normally called.
+FILE can also be a feature (i.e. a symbol), in which case FORM is
+evaluated whenever that feature is `provide'd."
(let ((elt (assoc file after-load-alist)))
- (or (member form (cdr elt))
- (progn
- (nconc elt (list form))
- ;; If the file has been loaded already, run FORM right away.
- (and (assoc file load-history)
- (eval form)))))
+ ;; Make sure there is an element for FILE.
+ (unless elt (setq elt (list file)) (push elt after-load-alist))
+ ;; Add FORM to the element if it isn't there.
+ (unless (member form (cdr elt))
+ (nconc elt (list form))
+ ;; If the file has been loaded already, run FORM right away.
+ (if (if (symbolp file)
+ (featurep file)
+ ;; Make sure `load-history' contains the files dumped with
+ ;; Emacs for the case that FILE is one of them.
+ (load-symbol-file-load-history)
+ (assoc file load-history))
+ (eval form))))
form)
(defun eval-next-after-load (file)
This makes or adds to an entry on `after-load-alist'.
FILE should be the name of a library, with no directory name."
(eval-after-load file (read)))
+\f
+;;; make-network-process wrappers
+
+(if (featurep 'make-network-process)
+ (progn
+
+(defun open-network-stream (name buffer host service)
+ "Open a TCP connection for a service to a host.
+Returns a subprocess-object to represent the connection.
+Input and output work as for subprocesses; `delete-process' closes it.
+Args are NAME BUFFER HOST SERVICE.
+NAME is name for process. It is modified if necessary to make it unique.
+BUFFER is the buffer (or buffer-name) to associate with the process.
+ Process output goes at end of that buffer, unless you specify
+ an output stream or filter function to handle the output.
+ BUFFER may be also nil, meaning that this process is not associated
+ with any buffer
+Third arg is name of the host to connect to, or its IP address.
+Fourth arg SERVICE is name of the service desired, or an integer
+specifying a port number to connect to."
+ (make-network-process :name name :buffer buffer
+ :host host :service service))
+
+(defun open-network-stream-nowait (name buffer host service &optional sentinel filter)
+ "Initiate connection to a TCP connection for a service to a host.
+It returns nil if non-blocking connects are not supported; otherwise,
+it returns a subprocess-object to represent the connection.
+
+This function is similar to `open-network-stream', except that this
+function returns before the connection is established. When the
+connection is completed, the sentinel function will be called with
+second arg matching `open' (if successful) or `failed' (on error).
+
+Args are NAME BUFFER HOST SERVICE SENTINEL FILTER.
+NAME, BUFFER, HOST, and SERVICE are as for `open-network-stream'.
+Optional args, SENTINEL and FILTER specifies the sentinel and filter
+functions to be used for this network stream."
+ (if (featurep 'make-network-process '(:nowait t))
+ (make-network-process :name name :buffer buffer :nowait t
+ :host host :service service
+ :filter filter :sentinel sentinel)))
+
+(defun open-network-stream-server (name buffer service &optional sentinel filter)
+ "Create a network server process for a TCP service.
+It returns nil if server processes are not supported; otherwise,
+it returns a subprocess-object to represent the server.
+
+When a client connects to the specified service, a new subprocess
+is created to handle the new connection, and the sentinel function
+is called for the new process.
+
+Args are NAME BUFFER SERVICE SENTINEL FILTER.
+NAME is name for the server process. Client processes are named by
+appending the ip-address and port number of the client to NAME.
+BUFFER is the buffer (or buffer-name) to associate with the server
+process. Client processes will not get a buffer if a process filter
+is specified or BUFFER is nil; otherwise, a new buffer is created for
+the client process. The name is similar to the process name.
+Third arg SERVICE is name of the service desired, or an integer
+specifying a port number to connect to. It may also be t to selected
+an unused port number for the server.
+Optional args, SENTINEL and FILTER specifies the sentinel and filter
+functions to be used for the client processes; the server process
+does not use these function."
+ (if (featurep 'make-network-process '(:server t))
+ (make-network-process :name name :buffer buffer
+ :service service :server t :noquery t
+ :sentinel sentinel :filter filter)))
+
+)) ;; (featurep 'make-network-process)
+
+
+;; compatibility
+
+(defun process-kill-without-query (process &optional flag)
+ "Say no query needed if PROCESS is running when Emacs is exited.
+Optional second argument if non-nil says to require a query.
+Value is t if a query was formerly required.
+New code should not use this function; use `process-query-on-exit-flag'
+or `set-process-query-on-exit-flag' instead."
+ (let ((old (process-query-on-exit-flag process)))
+ (set-process-query-on-exit-flag process nil)
+ old))
\f
;;;; Input and display facilities.
(let ((first (read-passwd prompt nil default))
(second (read-passwd "Confirm password: " nil default)))
(if (equal first second)
- (setq success first)
+ (progn
+ (and (arrayp second) (fillarray second ?\0))
+ (setq success first))
+ (and (arrayp first) (fillarray first ?\0))
+ (and (arrayp second) (fillarray second ?\0))
(message "Password not repeated accurately; please start over")
(sit-for 1))))
success)
(make-string (length pass) ?.))
(setq c (read-char-exclusive nil t))
(and (/= c ?\r) (/= c ?\n) (/= c ?\e)))
+ (clear-this-command-keys)
(if (= c ?\C-u)
- (setq pass "")
+ (progn
+ (and (arrayp pass) (fillarray pass ?\0))
+ (setq pass ""))
(if (and (/= c ?\b) (/= c ?\177))
- (setq pass (concat pass (char-to-string c)))
+ (let* ((new-char (char-to-string c))
+ (new-pass (concat pass new-char)))
+ (and (arrayp pass) (fillarray pass ?\0))
+ (fillarray new-char ?\0)
+ (setq c ?\0)
+ (setq pass new-pass))
(if (> (length pass) 0)
- (setq pass (substring pass 0 -1))))))
- (clear-this-command-keys)
+ (let ((new-pass (substring pass 0 -1)))
+ (and (arrayp pass) (fillarray pass ?\0))
+ (setq pass new-pass))))))
(message nil)
(or pass default ""))))
\f
+;;; Atomic change groups.
+
+(defmacro atomic-change-group (&rest body)
+ "Perform BODY as an atomic change group.
+This means that if BODY exits abnormally,
+all of its changes to the current buffer are undone.
+This works regadless of whether undo is enabled in the buffer.
+
+This mechanism is transparent to ordinary use of undo;
+if undo is enabled in the buffer and BODY succeeds, the
+user can undo the change normally."
+ (let ((handle (make-symbol "--change-group-handle--"))
+ (success (make-symbol "--change-group-success--")))
+ `(let ((,handle (prepare-change-group))
+ (,success nil))
+ (unwind-protect
+ (progn
+ ;; This is inside the unwind-protect because
+ ;; it enables undo if that was disabled; we need
+ ;; to make sure that it gets disabled again.
+ (activate-change-group ,handle)
+ ,@body
+ (setq ,success t))
+ ;; Either of these functions will disable undo
+ ;; if it was disabled before.
+ (if ,success
+ (accept-change-group ,handle)
+ (cancel-change-group ,handle))))))
+
+(defun prepare-change-group (&optional buffer)
+ "Return a handle for the current buffer's state, for a change group.
+If you specify BUFFER, make a handle for BUFFER's state instead.
+
+Pass the handle to `activate-change-group' afterward to initiate
+the actual changes of the change group.
+
+To finish the change group, call either `accept-change-group' or
+`cancel-change-group' passing the same handle as argument. Call
+`accept-change-group' to accept the changes in the group as final;
+call `cancel-change-group' to undo them all. You should use
+`unwind-protect' to make sure the group is always finished. The call
+to `activate-change-group' should be inside the `unwind-protect'.
+Once you finish the group, don't use the handle again--don't try to
+finish the same group twice. For a simple example of correct use, see
+the source code of `atomic-change-group'.
+
+The handle records only the specified buffer. To make a multibuffer
+change group, call this function once for each buffer you want to
+cover, then use `nconc' to combine the returned values, like this:
+
+ (nconc (prepare-change-group buffer-1)
+ (prepare-change-group buffer-2))
+
+You can then activate that multibuffer change group with a single
+call to `activate-change-group' and finish it with a single call
+to `accept-change-group' or `cancel-change-group'."
+
+ (list (cons (current-buffer) buffer-undo-list)))
+
+(defun activate-change-group (handle)
+ "Activate a change group made with `prepare-change-group' (which see)."
+ (dolist (elt handle)
+ (with-current-buffer (car elt)
+ (if (eq buffer-undo-list t)
+ (setq buffer-undo-list nil)))))
+
+(defun accept-change-group (handle)
+ "Finish a change group made with `prepare-change-group' (which see).
+This finishes the change group by accepting its changes as final."
+ (dolist (elt handle)
+ (with-current-buffer (car elt)
+ (if (eq elt t)
+ (setq buffer-undo-list t)))))
+
+(defun cancel-change-group (handle)
+ "Finish a change group made with `prepare-change-group' (which see).
+This finishes the change group by reverting all of its changes."
+ (dolist (elt handle)
+ (with-current-buffer (car elt)
+ (setq elt (cdr elt))
+ (let ((old-car
+ (if (consp elt) (car elt)))
+ (old-cdr
+ (if (consp elt) (cdr elt))))
+ ;; Temporarily truncate the undo log at ELT.
+ (when (consp elt)
+ (setcar elt nil) (setcdr elt nil))
+ (unless (eq last-command 'undo) (undo-start))
+ ;; Make sure there's no confusion.
+ (when (and (consp elt) (not (eq elt (last pending-undo-list))))
+ (error "Undoing to some unrelated state"))
+ ;; Undo it all.
+ (while pending-undo-list (undo-more 1))
+ ;; Reset the modified cons cell ELT to its original content.
+ (when (consp elt)
+ (setcar elt old-car)
+ (setcdr elt old-cdr))
+ ;; Revert the undo info to what it was when we grabbed the state.
+ (setq buffer-undo-list elt)))))
+\f
+;; For compatibility.
+(defalias 'redraw-modeline 'force-mode-line-update)
+
(defun force-mode-line-update (&optional all)
- "Force the mode-line of the current buffer to be redisplayed.
-With optional non-nil ALL, force redisplay of all mode-lines."
+ "Force the mode line of the current buffer to be redisplayed.
+With optional non-nil ALL, force redisplay of all mode lines."
(if all (save-excursion (set-buffer (other-buffer))))
(set-buffer-modified-p (buffer-modified-p)))
-(defun momentary-string-display (string pos &optional exit-char message)
+(defun momentary-string-display (string pos &optional exit-char message)
"Momentarily display STRING in the buffer at POS.
Display remains until next character is typed.
If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed;
(set-buffer-modified-p modified))))
\f
+;;;; Overlay operations
+
+(defun copy-overlay (o)
+ "Return a copy of overlay O."
+ (let ((o1 (make-overlay (overlay-start o) (overlay-end o)
+ ;; FIXME: there's no easy way to find the
+ ;; insertion-type of the two markers.
+ (overlay-buffer o)))
+ (props (overlay-properties o)))
+ (while props
+ (overlay-put o1 (pop props) (pop props)))
+ o1))
+
+(defun remove-overlays (beg end name val)
+ "Clear BEG and END of overlays whose property NAME has value VAL.
+Overlays might be moved and or split."
+ (if (< end beg)
+ (setq beg (prog1 end (setq end beg))))
+ (save-excursion
+ (dolist (o (overlays-in beg end))
+ (when (eq (overlay-get o name) val)
+ ;; Either push this overlay outside beg...end
+ ;; or split it to exclude beg...end
+ ;; or delete it entirely (if it is contained in beg...end).
+ (if (< (overlay-start o) beg)
+ (if (> (overlay-end o) end)
+ (progn
+ (move-overlay (copy-overlay o)
+ (overlay-start o) beg)
+ (move-overlay o end (overlay-end o)))
+ (move-overlay o (overlay-start o) beg))
+ (if (> (overlay-end o) end)
+ (move-overlay o end (overlay-end o))
+ (delete-overlay o)))))))
+\f
;;;; Miscellanea.
;; A number of major modes set this locally.
(defvar suspend-resume-hook nil
"Normal hook run by `suspend-emacs', after Emacs is continued.")
+(defvar temp-buffer-show-hook nil
+ "Normal hook run by `with-output-to-temp-buffer' after displaying the buffer.
+When the hook runs, the temporary buffer is current, and the window it
+was displayed in is selected. This hook is normally set up with a
+function to make the buffer read only, and find function names and
+variable names in it, provided the major mode is still Help mode.")
+
+(defvar temp-buffer-setup-hook nil
+ "Normal hook run by `with-output-to-temp-buffer' at the start.
+When the hook runs, the temporary buffer is current.
+This hook is normally set up with a function to put the buffer in Help
+mode.")
+
;; Avoid compiler warnings about this variable,
;; which has a special meaning on certain system types.
(defvar buffer-file-type nil
(defalias 'user-original-login-name 'user-login-name)
+(defvar yank-excluded-properties)
+
+(defun remove-yank-excluded-properties (start end)
+ "Remove `yank-excluded-properties' between START and END positions.
+Replaces `category' properties with their defined properties."
+ (let ((inhibit-read-only t))
+ ;; Replace any `category' property with the properties it stands for.
+ (unless (memq yank-excluded-properties '(t nil))
+ (save-excursion
+ (goto-char start)
+ (while (< (point) end)
+ (let ((cat (get-text-property (point) 'category))
+ run-end)
+ (when cat
+ (setq run-end
+ (next-single-property-change (point) 'category nil end))
+ (remove-list-of-text-properties (point) run-end '(category))
+ (add-text-properties (point) run-end (symbol-plist cat))
+ (goto-char (or run-end end)))
+ (setq run-end
+ (next-single-property-change (point) 'category nil end))
+ (goto-char (or run-end end))))))
+ (if (eq yank-excluded-properties t)
+ (set-text-properties start end nil)
+ (remove-list-of-text-properties start end
+ yank-excluded-properties))))
+
+(defun insert-for-yank (&rest strings)
+ "Insert STRINGS at point, stripping some text properties.
+Strip text properties from the inserted text
+according to `yank-excluded-properties'.
+Otherwise just like (insert STRINGS...)."
+ (let ((opoint (point)))
+ (apply 'insert strings)
+ (remove-yank-excluded-properties opoint (point))))
+
+(defun insert-buffer-substring-no-properties (buf &optional start end)
+ "Insert before point a substring of buffer BUFFER, without text properties.
+BUFFER may be a buffer or a buffer name.
+Arguments START and END are character numbers specifying the substring.
+They default to the beginning and the end of BUFFER."
+ (let ((opoint (point)))
+ (insert-buffer-substring buf start end)
+ (let ((inhibit-read-only t))
+ (set-text-properties opoint (point) nil))))
+
+(defun insert-buffer-substring-as-yank (buf &optional start end)
+ "Insert before point a part of buffer BUFFER, stripping some text properties.
+BUFFER may be a buffer or a buffer name. Arguments START and END are
+character numbers specifying the substring. They default to the
+beginning and the end of BUFFER. Strip text properties from the
+inserted text according to `yank-excluded-properties'."
+ (let ((opoint (point)))
+ (insert-buffer-substring buf start end)
+ (remove-yank-excluded-properties opoint (point))))
+
+\f
+;; Synchronous shell commands.
+
(defun start-process-shell-command (name buffer &rest args)
"Start a program in a subprocess. Return the process object for it.
Args are NAME BUFFER COMMAND &rest COMMAND-ARGS.
(t
(start-process name buffer shell-file-name 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.
+The remaining arguments are optional.
+The program's input comes from file INFILE (nil means `/dev/null').
+Insert output in BUFFER before point; t means current buffer;
+ nil for BUFFER means discard it; 0 means discard and don't wait.
+BUFFER can also have the form (REAL-BUFFER STDERR-FILE); in that case,
+REAL-BUFFER says what to do with standard output, as above,
+while STDERR-FILE says what to do with standard error in the child.
+STDERR-FILE may be nil (discard standard error output),
+t (mix it with ordinary output), or a file name string.
+
+Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.
+Remaining arguments are strings passed as additional arguments for COMMAND.
+Wildcards and redirection are handled as usual in the shell.
+
+If BUFFER is 0, `call-process-shell-command' returns immediately with value nil.
+Otherwise it waits for COMMAND to terminate and returns a numeric exit
+status or a signal description string.
+If you quit, the process is killed with SIGINT, or SIGKILL if you quit again."
+ (cond
+ ((eq system-type 'vax-vms)
+ (apply 'call-process command infile buffer display args))
+ ;; We used to use `exec' to replace the shell with the command,
+ ;; but that failed to handle (...) and semicolon, etc.
+ (t
+ (call-process shell-file-name
+ infile buffer display
+ shell-command-switch
+ (mapconcat 'identity (cons command args) " ")))))
\f
(defmacro with-current-buffer (buffer &rest body)
"Execute the forms in BODY with BUFFER as the current buffer.
(setq ,current-message (current-message))
(message "%s" ,temp-message))
,@body)
- (and ,temp-message ,current-message
- (message "%s" ,current-message))))))
+ (and ,temp-message
+ (if ,current-message
+ (message "%s" ,current-message)
+ (message nil)))))))
(defmacro with-temp-buffer (&rest body)
"Create a temporary buffer, and evaluate BODY there like `progn'.
(buffer-string)
(kill-buffer nil)))))
+(defmacro with-local-quit (&rest body)
+ "Execute BODY with `inhibit-quit' temporarily bound to nil."
+ `(condition-case nil
+ (let ((inhibit-quit nil))
+ ,@body)
+ (quit (setq quit-flag t))))
+
(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
(combine-after-change-execute)))
-(defvar combine-run-hooks t
- "List of hooks delayed. Or t if we're not delaying hooks.")
-
-(defmacro combine-run-hooks (&rest body)
- "Execute BODY, but delay any `run-hooks' until the end."
- (let ((saved-combine-run-hooks (make-symbol "saved-combine-run-hooks"))
- (saved-run-hooks (make-symbol "saved-run-hooks")))
- `(let ((,saved-combine-run-hooks combine-run-hooks)
- (,saved-run-hooks (symbol-function 'run-hooks)))
- (unwind-protect
- (progn
- ;; If we're not delaying hooks yet, setup the delaying mode
- (unless (listp combine-run-hooks)
- (setq combine-run-hooks nil)
- (fset 'run-hooks
- ,(lambda (&rest hooks)
- (setq combine-run-hooks
- (append combine-run-hooks hooks)))))
- ,@body)
- ;; If we were not already delaying, then it's now time to set things
- ;; back to normal and to execute the delayed hooks.
- (unless (listp ,saved-combine-run-hooks)
- (setq ,saved-combine-run-hooks combine-run-hooks)
- (fset 'run-hooks ,saved-run-hooks)
- (setq combine-run-hooks t)
- (apply 'run-hooks ,saved-combine-run-hooks))))))
-
+(defvar delay-mode-hooks nil
+ "If non-nil, `run-mode-hooks' should delay running the hooks.")
+(defvar delayed-mode-hooks nil
+ "List of delayed mode hooks waiting to be run.")
+(make-variable-buffer-local 'delayed-mode-hooks)
+
+(defun run-mode-hooks (&rest hooks)
+ "Run mode hooks `delayed-mode-hooks' and HOOKS, or delay HOOKS.
+Execution is delayed if `delay-mode-hooks' is non-nil.
+Major mode functions should use this."
+ (if delay-mode-hooks
+ ;; Delaying case.
+ (dolist (hook hooks)
+ (push hook delayed-mode-hooks))
+ ;; Normal case, just run the hook as before plus any delayed hooks.
+ (setq hooks (nconc (nreverse delayed-mode-hooks) hooks))
+ (setq delayed-mode-hooks nil)
+ (apply 'run-hooks hooks)))
+
+(defmacro delay-mode-hooks (&rest body)
+ "Execute BODY, but delay any `run-mode-hooks'.
+Only affects hooks run in the current buffer."
+ `(progn
+ (make-local-variable 'delay-mode-hooks)
+ (let ((delay-mode-hooks t))
+ ,@body)))
+
+;; PUBLIC: find if the current mode derives from another.
+
+(defun derived-mode-p (&rest modes)
+ "Non-nil if the current major mode is derived from one of MODES.
+Uses the `derived-mode-parent' property of the symbol to trace backwards."
+ (let ((parent major-mode))
+ (while (and (not (memq parent modes))
+ (setq parent (get parent 'derived-mode-parent))))
+ parent))
(defmacro with-syntax-table (table &rest body)
"Evaluate BODY with syntax table of current buffer set to a copy of TABLE.
(set-buffer ,old-buffer)
(set-syntax-table ,old-table))))))
\f
+;;; Matching and substitution
+
(defvar save-match-data-internal)
;; We use save-match-data-internal as the local variable because
;; We used to use an uninterned symbol; the compiler handles that properly
;; now, but it generates slower code.
(defmacro save-match-data (&rest body)
- "Execute the BODY forms, restoring the global value of the match data."
+ "Execute the BODY forms, restoring the global value of the match data.
+The value returned is the value of the last form in BODY."
;; It is better not to use backquote here,
;; because that makes a bootstrapping problem
;; if you need to recompile all the Lisp files using interpreted code.
;; string looking for matches of REGEXP and building up a (reversed)
;; list MATCHES. This comprises segments of STRING which weren't
;; matched interspersed with replacements for segments that were.
- ;; [For a `large' number of replacments it's more efficient to
+ ;; [For a `large' number of replacements it's more efficient to
;; operate in a temporary buffer; we can't tell from the function's
;; args whether to choose the buffer-based implementation, though it
;; might be reasonable to do so for long enough STRING.]
(defun make-syntax-table (&optional oldtable)
"Return a new syntax table.
-If OLDTABLE is non-nil, copy OLDTABLE.
-Otherwise, create a syntax table which inherits
-all letters and control characters from the standard syntax table;
-other characters are copied from the standard syntax table."
- (if oldtable
- (copy-syntax-table oldtable)
- (let ((table (copy-syntax-table))
- i)
- (setq i 0)
- (while (<= i 31)
- (aset table i nil)
- (setq i (1+ i)))
- (setq i ?A)
- (while (<= i ?Z)
- (aset table i nil)
- (setq i (1+ i)))
- (setq i ?a)
- (while (<= i ?z)
- (aset table i nil)
- (setq i (1+ i)))
- (setq i 128)
- (while (<= i 255)
- (aset table i nil)
- (setq i (1+ i)))
- table)))
+Create a syntax table which inherits from OLDTABLE (if non-nil) or
+from `standard-syntax-table' otherwise."
+ (let ((table (make-char-table 'syntax-table nil)))
+ (set-char-table-parent table (or oldtable (standard-syntax-table)))
+ table))
(defun add-to-invisibility-spec (arg)
"Add elements to `buffer-invisibility-spec'.
(eq (car object) 'frame-configuration)))
(defun functionp (object)
- "Non-nil if OBJECT is a type of object that can be called as a function."
- (or (subrp object) (byte-code-function-p object)
- (eq (car-safe object) 'lambda)
- (and (symbolp object) (fboundp object))))
-
-;; now in fns.c
-;(defun nth (n list)
-; "Returns the Nth element of LIST.
-;N counts from zero. If LIST is not that long, nil is returned."
-; (car (nthcdr n list)))
-;
-;(defun copy-alist (alist)
-; "Return a copy of ALIST.
-;This is a new alist which represents the same mapping
-;from objects to objects, but does not share the alist structure with ALIST.
-;The objects mapped (cars and cdrs of elements of the alist)
-;are shared, however."
-; (setq alist (copy-sequence alist))
-; (let ((tail alist))
-; (while tail
-; (if (consp (car tail))
-; (setcar tail (cons (car (car tail)) (cdr (car tail)))))
-; (setq tail (cdr tail))))
-; alist)
+ "Non-nil iff OBJECT is a type of object that can be called as a function."
+ (or (and (symbolp object) (fboundp object)
+ (condition-case nil
+ (setq object (indirect-function object))
+ (error nil))
+ (eq (car-safe object) 'autoload)
+ (not (car-safe (cdr-safe (cdr-safe (cdr-safe (cdr-safe object)))))))
+ (subrp object) (byte-code-function-p object)
+ (eq (car-safe object) 'lambda)))
+
+(defun interactive-form (function)
+ "Return the interactive form of FUNCTION.
+If function is a command (see `commandp'), value is a list of the form
+\(interactive SPEC). If function is not a command, return nil."
+ (setq function (indirect-function function))
+ (when (commandp function)
+ (cond ((byte-code-function-p function)
+ (when (> (length function) 5)
+ (let ((spec (aref function 5)))
+ (if spec
+ (list 'interactive spec)
+ (list 'interactive)))))
+ ((subrp function)
+ (subr-interactive-form function))
+ ((eq (car-safe function) 'lambda)
+ (setq function (cddr function))
+ (when (stringp (car function))
+ (setq function (cdr function)))
+ (let ((form (car function)))
+ (when (eq (car-safe form) 'interactive)
+ (copy-sequence form)))))))
(defun assq-delete-all (key alist)
"Delete from ALIST all elements whose car is KEY.
(setq tail (cdr tail)))
alist))
-(defun make-temp-file (prefix &optional dir-flag)
+(defun make-temp-file (prefix &optional dir-flag suffix)
"Create a temporary file.
The returned file name (created by appending some random characters at the end
of PREFIX, and expanding against `temporary-file-directory' if necessary,
is guaranteed to point to a newly created empty file.
You can then use `write-region' to write new data into the file.
-If DIR-FLAG is non-nil, create a new empty directory instead of a file."
+If DIR-FLAG is non-nil, create a new empty directory instead of a file.
+
+If SUFFIX is non-nil, add that at the end of the file name."
(let (file)
(while (condition-case ()
(progn
(setq file
(make-temp-name
(expand-file-name prefix temporary-file-directory)))
+ (if suffix
+ (setq file (concat file suffix)))
(if dir-flag
(make-directory file)
(write-region "" nil file nil 'silent nil 'excl))
nil)
- (file-already-exists t))
+ (file-already-exists t))
;; the file was somehow created by someone else between
;; `make-temp-name' and `write-region', let's try again.
nil)
included in the mode-line minor mode menu.
If TOGGLE has a `:menu-tag', that is used for the menu item's label."
(unless toggle-fun (setq toggle-fun toggle))
- ;; Add the toggle to the minor-modes menu if requested.
- (when (get toggle :included)
- (define-key mode-line-mode-menu
- (vector toggle)
- (list 'menu-item
- (or (get toggle :menu-tag)
- (if (stringp name) name (symbol-name toggle)))
- toggle-fun
- :button (cons :toggle toggle))))
;; Add the name to the minor-mode-alist.
(when name
(let ((existing (assq toggle minor-mode-alist)))
(when (and (stringp name) (not (get-text-property 0 'local-map name)))
(setq name
- (apply 'propertize name
- 'local-map (make-mode-line-mouse2-map toggle-fun)
- (unless (get-text-property 0 'help-echo name)
- (list 'help-echo
- (format "mouse-2: turn off %S" toggle))))))
+ (propertize name
+ 'local-map mode-line-minor-mode-keymap
+ 'help-echo "mouse-3: minor mode menu")))
(if existing
(setcdr existing (list name))
(let ((tail minor-mode-alist) found)
(nconc found (list (list toggle name)) rest))
(setq minor-mode-alist (cons (list toggle name)
minor-mode-alist)))))))
+ ;; Add the toggle to the minor-modes menu if requested.
+ (when (get toggle :included)
+ (define-key mode-line-mode-menu
+ (vector toggle)
+ (list 'menu-item
+ (concat
+ (or (get toggle :menu-tag)
+ (if (stringp name) name (symbol-name toggle)))
+ (let ((mode-name (if (stringp name) name
+ (if (symbolp name) (symbol-value name)))))
+ (if mode-name
+ (concat " (" mode-name ")"))))
+ toggle-fun
+ :button (cons :toggle toggle))))
+
;; Add the map to the minor-mode-map-alist.
(when keymap
(let ((existing (assq toggle minor-mode-map-alist)))
(nconc found (list (cons toggle keymap)) rest))
(setq minor-mode-map-alist (cons (cons toggle keymap)
minor-mode-map-alist))))))))
+\f
+;; Clones ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun text-clone-maintain (ol1 after beg end &optional len)
+ "Propagate the changes made under the overlay OL1 to the other clones.
+This is used on the `modification-hooks' property of text clones."
+ (when (and after (not undo-in-progress) (overlay-start ol1))
+ (let ((margin (if (overlay-get ol1 'text-clone-spreadp) 1 0)))
+ (setq beg (max beg (+ (overlay-start ol1) margin)))
+ (setq end (min end (- (overlay-end ol1) margin)))
+ (when (<= beg end)
+ (save-excursion
+ (when (overlay-get ol1 'text-clone-syntax)
+ ;; Check content of the clone's text.
+ (let ((cbeg (+ (overlay-start ol1) margin))
+ (cend (- (overlay-end ol1) margin)))
+ (goto-char cbeg)
+ (save-match-data
+ (if (not (re-search-forward
+ (overlay-get ol1 'text-clone-syntax) cend t))
+ ;; Mark the overlay for deletion.
+ (overlay-put ol1 'text-clones nil)
+ (when (< (match-end 0) cend)
+ ;; Shrink the clone at its end.
+ (setq end (min end (match-end 0)))
+ (move-overlay ol1 (overlay-start ol1)
+ (+ (match-end 0) margin)))
+ (when (> (match-beginning 0) cbeg)
+ ;; Shrink the clone at its beginning.
+ (setq beg (max (match-beginning 0) beg))
+ (move-overlay ol1 (- (match-beginning 0) margin)
+ (overlay-end ol1)))))))
+ ;; Now go ahead and update the clones.
+ (let ((head (- beg (overlay-start ol1)))
+ (tail (- (overlay-end ol1) end))
+ (str (buffer-substring beg end))
+ (nothing-left t)
+ (inhibit-modification-hooks t))
+ (dolist (ol2 (overlay-get ol1 'text-clones))
+ (let ((oe (overlay-end ol2)))
+ (unless (or (eq ol1 ol2) (null oe))
+ (setq nothing-left nil)
+ (let ((mod-beg (+ (overlay-start ol2) head)))
+ ;;(overlay-put ol2 'modification-hooks nil)
+ (goto-char (- (overlay-end ol2) tail))
+ (unless (> mod-beg (point))
+ (save-excursion (insert str))
+ (delete-region mod-beg (point)))
+ ;;(overlay-put ol2 'modification-hooks '(text-clone-maintain))
+ ))))
+ (if nothing-left (delete-overlay ol1))))))))
+
+(defun text-clone-create (start end &optional spreadp syntax)
+ "Create a text clone of START...END at point.
+Text clones are chunks of text that are automatically kept identical:
+changes done to one of the clones will be immediately propagated to the other.
+
+The buffer's content at point is assumed to be already identical to
+the one between START and END.
+If SYNTAX is provided it's a regexp that describes the possible text of
+the clones; the clone will be shrunk or killed if necessary to ensure that
+its text matches the regexp.
+If SPREADP is non-nil it indicates that text inserted before/after the
+clone should be incorporated in the clone."
+ ;; To deal with SPREADP we can either use an overlay with `nil t' along
+ ;; with insert-(behind|in-front-of)-hooks or use a slightly larger overlay
+ ;; (with a one-char margin at each end) with `t nil'.
+ ;; We opted for a larger overlay because it behaves better in the case
+ ;; where the clone is reduced to the empty string (we want the overlay to
+ ;; stay when the clone's content is the empty string and we want to use
+ ;; `evaporate' to make sure those overlays get deleted when needed).
+ ;;
+ (let* ((pt-end (+ (point) (- end start)))
+ (start-margin (if (or (not spreadp) (bobp) (<= start (point-min)))
+ 0 1))
+ (end-margin (if (or (not spreadp)
+ (>= pt-end (point-max))
+ (>= start (point-max)))
+ 0 1))
+ (ol1 (make-overlay (- start start-margin) (+ end end-margin) nil t))
+ (ol2 (make-overlay (- (point) start-margin) (+ pt-end end-margin) nil t))
+ (dups (list ol1 ol2)))
+ (overlay-put ol1 'modification-hooks '(text-clone-maintain))
+ (when spreadp (overlay-put ol1 'text-clone-spreadp t))
+ (when syntax (overlay-put ol1 'text-clone-syntax syntax))
+ ;;(overlay-put ol1 'face 'underline)
+ (overlay-put ol1 'evaporate t)
+ (overlay-put ol1 'text-clones dups)
+ ;;
+ (overlay-put ol2 'modification-hooks '(text-clone-maintain))
+ (when spreadp (overlay-put ol2 'text-clone-spreadp t))
+ (when syntax (overlay-put ol2 'text-clone-syntax syntax))
+ ;;(overlay-put ol2 'face 'underline)
+ (overlay-put ol2 'evaporate t)
+ (overlay-put ol2 'text-clones dups)))
+\f
+(defun play-sound (sound)
+ "SOUND is a list of the form `(sound KEYWORD VALUE...)'.
+The following keywords are recognized:
+
+ :file FILE - read sound data from FILE. If FILE isn't an
+absolute file name, it is searched in `data-directory'.
+
+ :data DATA - read sound data from string DATA.
+
+Exactly one of :file or :data must be present.
+
+ :volume VOL - set volume to VOL. VOL must an integer in the
+range 0..100 or a float in the range 0..1.0. If not specified,
+don't change the volume setting of the sound device.
+ :device DEVICE - play sound on DEVICE. If not specified,
+a system-dependent default device name is used."
+ (unless (fboundp 'play-sound-internal)
+ (error "This Emacs binary lacks sound support"))
+ (play-sound-internal sound))
;;; subr.el ends here
HCoop / bpt / emacs.git / blobdiff