;;; 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.
(define-key map (char-to-string loop) 'digit-argument)
(setq loop (1+ loop))))))
-(when (and (not (fboundp 'set-keymap-parents))
- (fboundp 'make-composed-keymap))
- (defun set-keymap-parents (map parents)
- "Set MAP to inherit from PARENTS.
-PARENTS can be either nil or a keymap or a list of keymaps."
- (set-keymap-parent map
- (if (or (null parents) (keymapp parents)) parents
- (make-composed-keymap parents)))))
-
;Moved to keymap.c
;(defun copy-keymap (keymap)
; "Return a copy of KEYMAP"
\(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
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
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 (unless (local-variable-if-set-p hook) (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 (unless (local-variable-if-set-p hook) (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 &optional append)
"Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.
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'
into a hook function that will be run only after loading the package.
(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.
(defun subst-char-in-string (fromchar tochar string &optional inplace)
"Replace FROMCHAR with TOCHAR in STRING each time it occurs.
Unless optional argument INPLACE is non-nil, return a new string."
- (if inplace (error "bouh!"))
- (mapconcat (lambda (c) (char-to-string (if (equal c fromchar) tochar c)))
- string ""))
+ (let ((i (length string))
+ (newstr (if inplace string (copy-sequence string))))
+ (while (> i 0)
+ (setq i (1- i))
+ (if (eq (aref newstr i) fromchar)
+ (aset newstr i tochar)))
+ newstr))
(defun replace-regexp-in-string (regexp rep string &optional
fixedcase literal subexp start)
;; 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.
-;; XEmacs compatibility/convenience.
-(if (fboundp 'play-sound)
- (defun play-sound-file (file &optional volume device)
- "Play sound stored in FILE.
-VOLUME and DEVICE correspond to the keywords of the sound
-specification for `play-sound'."
- (interactive "fPlay sound file: ")
- (let ((sound (list :file file)))
- (if volume
- (plist-put sound :volume volume))
- (if device
- (plist-put sound :device device))
- (push 'sound sound)
- (play-sound sound))))
+ :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