(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 (ie. text-mode).
NAME: a string which will appear in the status line (ie. \"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.
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."
(if (and docstring (not (stringp docstring)))
(progn (setq body (cons docstring body))
(setq docstring nil)))
(setq docstring (or docstring (derived-mode-make-docstring parent child)))
(` (progn
(derived-mode-init-mode-variables '(, child))
(put '(, child) 'derived-mode-parent '(, parent))
(defun (, child) ()
(, docstring)
(interactive)
((, parent))
(if (get '(, parent) 'special)
(put '(, child) 'special t))
(setq major-mode '(, child))
(setq mode-name (, name))
(derived-mode-set-keymap '(, child))
(derived-mode-set-syntax-table '(, child))
(derived-mode-set-abbrev-table '(, child))
(,@ body)
(derived-mode-run-hooks '(, child))))))
(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."
(while (get mode 'derived-mode-parent)
(setq mode (get mode 'derived-mode-parent)))
mode)
(defsubst derived-mode-setup-function-name (mode)
"Construct a setup-function name based on a mode name."
(intern (concat (symbol-name mode) "-setup")))
(defsubst derived-mode-hook-name (mode)
"Construct the mode hook name based on mode name MODE."
(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")))
(defun derived-mode-init-mode-variables (mode)
"Initialise 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-make-docstring (parent child)
"Construct a docstring for a new mode if none is provided."
(format "This major mode is a variant of `%s', created by `define-derived-mode'.
It inherits all of the parent's attributes, but has its own keymap,
abbrev table and syntax table:
`%s-map' and `%s-syntax-table'
which more-or-less shadow
`%s-map' and `%s-syntax-table'
\\{%s-map}" parent child child parent parent child))
(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 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
(function
(lambda (symbol)
(or (intern-soft (symbol-name symbol) new)
(define-abbrev new (symbol-name symbol)
(symbol-value symbol) (symbol-function symbol)))))
old)))
(provide 'derived)