;;; 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
+;; Free Software Foundation, Inc.
;; 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.
\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.
SEQ must be a list, vector, or string. The comparison is done with `equal'."
"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))
+ (while (and list (not (eq t (compare-strings elt 0 nil (car list) 0 nil t))))
+ (setq list (cdr list)))
+ list)
\f
;;;; Keymap support.
\(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)))))
(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)
(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
(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'.
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)))
(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)
(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
(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)))))))
+
;;;; Miscellanea.
;; A number of major modes set this locally.
(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.
(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)))
(defmacro with-syntax-table (table &rest body)
"Evaluate BODY with syntax table of current buffer set to a copy of TABLE.
;; 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)
+ (setq object (indirect-function object))
+ (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.
(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)
(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)
(push 'sound sound)
(play-sound sound))))
+;; 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)))
+
;;; subr.el ends here