(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').
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.
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."
(when (and docstring (not (stringp docstring)))
(push docstring body)
(setq docstring nil))
(unless parent (setq parent 'fundamental-mode))
(let ((map (derived-mode-map-name child))
(syntax (derived-mode-syntax-table-name child))
(abbrev (derived-mode-abbrev-table-name child))
(hook (derived-mode-hook-name child))
(docstring (derived-mode-make-docstring parent child docstring)))
`(progn
(defvar ,map (make-sparse-keymap))
(defvar ,syntax (make-char-table 'syntax-table nil))
(defvar ,abbrev)
(define-abbrev-table ',abbrev nil)
(put ',child 'derived-mode-parent ',parent)
(defun ,child ()
,docstring
(interactive)
(,parent)
(if (get (quote ,parent) 'special)
(put (quote ,child) 'special t))
(setq major-mode (quote ,child))
(setq mode-name ,name)
(unless (keymap-parent ,map)
(set-keymap-parent ,map (current-local-map)))
(let ((parent (char-table-parent ,syntax)))
(unless (and parent (not (eq parent (standard-syntax-table))))
(set-char-table-parent ,syntax (syntax-table))))
(when local-abbrev-table
(mapatoms
(lambda (symbol)
(or (intern-soft (symbol-name symbol) ,abbrev)
(define-abbrev ,abbrev (symbol-name symbol)
(symbol-value symbol) (symbol-function symbol))))
local-abbrev-table))
(use-local-map ,map)
(set-syntax-table ,syntax)
(setq local-abbrev-table ,abbrev)
,@body
(run-hooks ',hook)))))
(defun derived-mode-p (&rest modes)
"Non-nil if the current major mode is derived from one of MODES.
Uses the `derived-mode-parent' property of the symbol to trace backwards."
(let ((parent major-mode))
(while (and (not (memq parent modes))
(setq parent (get parent 'derived-mode-parent))))
parent))
(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 derive from each other and from `fundamental-mode',
this function is not very useful. Use `derived-mode-p' instead."
(while (get mode 'derived-mode-parent)
(setq mode (get mode 'derived-mode-parent)))
mode)
(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-make-docstring (parent child &optional docstring)
"Construct a docstring for a new mode if none is provided."
(let ((map (derived-mode-map-name child))
(syntax (derived-mode-syntax-table-name child))
(abbrev (derived-mode-abbrev-table-name child))
(hook (derived-mode-hook-name child)))
(unless (stringp docstring)
(setq docstring
(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 (eq parent 'fundamental-mode)
"\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)
"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-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)