(eval-when-compile (require 'cl))
(defsubst derived-mode-hook-name (mode)
"Construct a mode-hook name based on a MODE name."
(intern (concat (symbol-name mode) "-hook")))
(defsubst derived-mode-map-name (mode)
"Construct a map name based on a MODE name."
(intern (concat (symbol-name mode) "-map")))
(defsubst derived-mode-syntax-table-name (mode)
"Construct a syntax-table name based on a MODE name."
(intern (concat (symbol-name mode) "-syntax-table")))
(defsubst derived-mode-abbrev-table-name (mode)
"Construct an abbrev-table name based on a MODE name."
(intern (concat (symbol-name mode) "-abbrev-table")))
(defmacro define-derived-mode (child parent name &optional docstring &rest body)
"Create a new mode as a variant of an existing mode.
The arguments to this command are as follow:
CHILD: the name of the command for the derived mode.
PARENT: the name of the command for the parent mode (e.g. `text-mode')
or nil if there is no parent.
NAME: a string which will appear in the status line (e.g. \"Hypertext\")
DOCSTRING: an optional documentation string--if you do not supply one,
the function will attempt to invent something useful.
BODY: forms to execute just before running the
hooks for the new mode. Do not use `interactive' here.
BODY can start with a bunch of keyword arguments. The following keyword
arguments are currently understood:
:group GROUP
Declare the customization group that corresponds to this mode.
The command `customize-mode' uses this.
:syntax-table TABLE
Use TABLE instead of the default.
A nil value means to simply use the same syntax-table as the parent.
:abbrev-table TABLE
Use TABLE instead of the default.
A nil value means to simply use the same abbrev-table as the parent.
Here is how you could define LaTeX-Thesis mode as a variant of LaTeX mode:
(define-derived-mode LaTeX-thesis-mode LaTeX-mode \"LaTeX-Thesis\")
You could then make new key bindings for `LaTeX-thesis-mode-map'
without changing regular LaTeX mode. In this example, BODY is empty,
and DOCSTRING is generated by default.
On a more complicated level, the following command uses `sgml-mode' as
the parent, and then sets the variable `case-fold-search' to nil:
(define-derived-mode article-mode sgml-mode \"Article\"
\"Major mode for editing technical articles.\"
(setq case-fold-search nil))
Note that if the documentation string had been left out, it would have
been generated automatically, with a reference to the keymap.
The new mode runs the hook constructed by the function
`derived-mode-hook-name'.
See Info node `(elisp)Derived Modes' for more details."
(declare (debug (&define name symbolp sexp [&optional stringp]
[&rest keywordp sexp] def-body)))
(when (and docstring (not (stringp docstring)))
(push docstring body)
(setq docstring nil))
(when (eq parent 'fundamental-mode) (setq parent nil))
(let ((map (derived-mode-map-name child))
(syntax (derived-mode-syntax-table-name child))
(abbrev (derived-mode-abbrev-table-name child))
(declare-abbrev t)
(declare-syntax t)
(hook (derived-mode-hook-name child))
(group nil))
(while (keywordp (car body))
(case (pop body)
(:group (setq group (pop body)))
(:abbrev-table (setq abbrev (pop body)) (setq declare-abbrev nil))
(:syntax-table (setq syntax (pop body)) (setq declare-syntax nil))
(t (pop body))))
(setq docstring (derived-mode-make-docstring
parent child docstring syntax abbrev))
`(progn
(unless (get ',hook 'variable-documentation)
(put ',hook 'variable-documentation
,(format "Hook run when entering %s mode.
No problems result if this variable is not bound.
`add-hook' automatically binds it. (This is true for all hook variables.)"
name)))
(unless (boundp ',map)
(put ',map 'definition-name ',child))
(defvar ,map (make-sparse-keymap))
,(if declare-syntax
`(progn
(unless (boundp ',syntax)
(put ',syntax 'definition-name ',child))
(defvar ,syntax (make-syntax-table))))
,(if declare-abbrev
`(progn
(put ',abbrev 'definition-name ',child)
(defvar ,abbrev
(progn (define-abbrev-table ',abbrev nil) ,abbrev))))
(put ',child 'derived-mode-parent ',parent)
,(if group `(put ',child 'custom-mode-group ,group))
(defun ,child ()
,docstring
(interactive)
(delay-mode-hooks
(,(or parent 'kill-all-local-variables))
(setq major-mode (quote ,child))
(setq mode-name ,name)
,(when parent
`(progn
(if (get (quote ,parent) 'mode-class)
(put (quote ,child) 'mode-class
(get (quote ,parent) 'mode-class)))
(unless (keymap-parent ,map)
(set-keymap-parent ,map (current-local-map)))
,(when declare-syntax
`(let ((parent (char-table-parent ,syntax)))
(unless (and parent
(not (eq parent (standard-syntax-table))))
(set-char-table-parent ,syntax (syntax-table)))))))
(use-local-map ,map)
,(when syntax `(set-syntax-table ,syntax))
,(when abbrev `(setq local-abbrev-table ,abbrev))
,@body
)
(if (fboundp 'run-mode-hooks)
(run-mode-hooks ',hook)
(run-hooks ',hook))))))
(defun derived-mode-class (mode)
"Find the class of a major MODE.
A mode's class is the first ancestor which is NOT a derived mode.
Use the `derived-mode-parent' property of the symbol to trace backwards.
Since major-modes might all derive from `fundamental-mode', this function
is not very useful."
(while (get mode 'derived-mode-parent)
(setq mode (get mode 'derived-mode-parent)))
mode)
(make-obsolete 'derived-mode-class 'derived-mode-p "22.1")
(defun derived-mode-make-docstring (parent child &optional
docstring syntax abbrev)
"Construct a docstring for a new mode if none is provided."
(let ((map (derived-mode-map-name child))
(hook (derived-mode-hook-name child)))
(unless (stringp docstring)
(setq docstring
(if (null parent)
(format "Major-mode.
Uses keymap `%s', abbrev table `%s' and syntax-table `%s'." map abbrev syntax)
(format "Major mode derived from `%s' by `define-derived-mode'.
It inherits all of the parent's attributes, but has its own keymap,
abbrev table and syntax table:
`%s', `%s' and `%s'
which more-or-less shadow %s's corresponding tables."
parent map abbrev syntax parent))))
(unless (string-match (regexp-quote (symbol-name hook)) docstring)
(setq docstring
(concat docstring
(if (null parent)
"\n\nThis mode "
(concat
"\n\nIn addition to any hooks its parent mode "
(if (string-match (regexp-quote (format "`%s'" parent))
docstring) nil
(format "`%s' " parent))
"might have run,\nthis mode "))
(format "runs the hook `%s'" hook)
", as the final step\nduring initialization.")))
(unless (string-match "\\\\[{[]" docstring)
(setq docstring (concat docstring "\n\n\\{" (symbol-name map) "}")))
docstring))
(defsubst derived-mode-setup-function-name (mode)
"Construct a setup-function name based on a MODE name."
(intern (concat (symbol-name mode) "-setup")))
(defun derived-mode-init-mode-variables (mode)
"Initialize variables for a new MODE.
Right now, if they don't already exist, set up a blank keymap, an
empty syntax table, and an empty abbrev table -- these will be merged
the first time the mode is used."
(if (boundp (derived-mode-map-name mode))
t
(eval `(defvar ,(derived-mode-map-name mode)
(make-sparse-keymap)
,(format "Keymap for %s." mode)))
(put (derived-mode-map-name mode) 'derived-mode-unmerged t))
(if (boundp (derived-mode-syntax-table-name mode))
t
(eval `(defvar ,(derived-mode-syntax-table-name mode)
(make-char-table 'syntax-table nil)
,(format "Syntax table for %s." mode)))
(put (derived-mode-syntax-table-name mode) 'derived-mode-unmerged t))
(if (boundp (derived-mode-abbrev-table-name mode))
t
(eval `(defvar ,(derived-mode-abbrev-table-name mode)
(progn
(define-abbrev-table (derived-mode-abbrev-table-name mode) nil)
(make-abbrev-table))
,(format "Abbrev table for %s." mode)))))
(defun derived-mode-set-keymap (mode)
"Set the keymap of the new MODE, maybe merging with the parent."
(let* ((map-name (derived-mode-map-name mode))
(new-map (eval map-name))
(old-map (current-local-map)))
(and old-map
(get map-name 'derived-mode-unmerged)
(derived-mode-merge-keymaps old-map new-map))
(put map-name 'derived-mode-unmerged nil)
(use-local-map new-map)))
(defun derived-mode-set-syntax-table (mode)
"Set the syntax table of the new MODE, maybe merging with the parent."
(let* ((table-name (derived-mode-syntax-table-name mode))
(old-table (syntax-table))
(new-table (eval table-name)))
(if (get table-name 'derived-mode-unmerged)
(derived-mode-merge-syntax-tables old-table new-table))
(put table-name 'derived-mode-unmerged nil)
(set-syntax-table new-table)))
(defun derived-mode-set-abbrev-table (mode)
"Set the abbrev table for MODE if it exists.
Always merge its parent into it, since the merge is non-destructive."
(let* ((table-name (derived-mode-abbrev-table-name mode))
(old-table local-abbrev-table)
(new-table (eval table-name)))
(derived-mode-merge-abbrev-tables old-table new-table)
(setq local-abbrev-table new-table)))
(defun derived-mode-run-hooks (mode)
"Run the mode hook for MODE."
(let ((hooks-name (derived-mode-hook-name mode)))
(if (boundp hooks-name)
(run-hooks hooks-name))))
(defun derived-mode-merge-keymaps (old new)
"Merge an OLD keymap into a NEW one.
The old keymap is set to be the last cdr of the new one, so that there will
be automatic inheritance."
(let ((tail new))
(while (consp tail)
(and (consp (car tail))
(let* ((key (vector (car (car tail))))
(subnew (lookup-key new key))
(subold (lookup-key old key)))
(and (keymapp subnew) (keymapp subold)
(derived-mode-merge-keymaps subold subnew))))
(and (vectorp (car tail))
(let ((i (1- (length (car tail)))))
(while (>= i 0)
(let* ((key (vector i))
(subnew (lookup-key new key))
(subold (lookup-key old key)))
(and (keymapp subnew) (keymapp subold)
(derived-mode-merge-keymaps subold subnew)))
(setq i (1- i)))))
(setq tail (cdr tail))))
(setcdr (nthcdr (1- (length new)) new) old))
(defun derived-mode-merge-syntax-tables (old new)
"Merge an OLD syntax table into a NEW one.
Where the new table already has an entry, nothing is copied from the old one."
(set-char-table-parent new old))
(defun derived-mode-merge-abbrev-tables (old new)
(if old
(mapatoms
(lambda (symbol)
(or (intern-soft (symbol-name symbol) new)
(define-abbrev new (symbol-name symbol)
(symbol-value symbol) (symbol-function symbol))))
old)))
(provide 'derived)