\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
\(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)))))
(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 (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)))
(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.
It does nothing if FORM is already on the list for FILE.
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."
- ;; Make sure `load-history' contains the files dumped with Emacs
- ;; for the case that FILE is one of the files dumped with Emacs.
- (load-symbol-file-load-history)
- ;; 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.
+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)
(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 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.
The syntax table of the current buffer is saved, BODY is evaluated, and the
;; 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))))
+ "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.
(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)
(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