\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
(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
(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.
(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
(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 from the
-`standard-syntax-table'."
- (if oldtable
- (copy-syntax-table oldtable)
- (let ((table (make-char-table 'syntax-table nil)))
- (set-char-table-parent table (standard-syntax-table))
- 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.
(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