/elisp/mode-info/mi-util.el
Emacs Lisp | 255 lines | 194 code | 38 blank | 23 comment | 7 complexity | 41580579951dcc890fc11429c8282043 MD5 | raw file
- ;;; mi-util.el --- Utility functions of mode-info
- ;; Copyright (C) 2002 TSUCHIYA Masatoshi <tsuchiya@namazu.org>
- ;; Authors: TSUCHIYA Masatoshi <tsuchiya@namazu.org>
- ;; Keywords: info
- ;; This file is a part of mode-info.
- ;; This program is free software; you can redistribute it and/or modify
- ;; it under the terms of the GNU General Public License as published by
- ;; the Free Software Foundation; either version 2, or (at your option)
- ;; any later version.
- ;; This program is distributed in the hope that it will be useful,
- ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
- ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ;; GNU General Public License for more details.
- ;; You should have received a copy of the GNU General Public License
- ;; along with this program; if not, you can either send email to this
- ;; program's maintainer or write to: The Free Software Foundation,
- ;; Inc.; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
- ;;; Commentary:
- ;; This file provides utility functions and an object system of
- ;; mode-info.
- ;;; Code:
- (eval-when-compile
- (require 'cl))
- (eval-and-compile
- (cond
- ((boundp 'MULE)
- (require 'poe)
- (require 'pcustom))))
- (defconst mode-info-titles-type
- '(repeat (choice (string :tag "Title")
- (repeat :tag "Aliases" (string :tag "Title"))))
- "A widget type for editing `mode-info-*-titles'.")
- (put 'mode-info-static-if 'edebug-form-spec '(form form body))
- (put 'mode-info-static-if 'lisp-indent-function 2)
- (defmacro mode-info-static-if (cond then &rest else)
- "Like `if', but evaluate COND at compile time."
- (if (eval cond) then `(progn ,@else)))
- (put 'mode-info-static-when 'edebug-form-spec '(form body))
- (put 'mode-info-static-when 'lisp-indent-function 1)
- (defmacro mode-info-static-when (cond &rest body)
- "Like `when', but evaluate COND at compile time."
- (if (eval cond) `(progn ,@body)))
- (put 'mode-info-save-syntax-table 'edebug-form-spec '(body))
- (put 'mode-info-save-syntax-table 'lisp-indent-function 0)
- (defmacro mode-info-save-syntax-table (&rest body)
- "Save syntax table of this current buffer; execute BODY; restore it."
- (let ((orig-table (make-symbol "orig-table")))
- `(let ((,orig-table (syntax-table)))
- (unwind-protect
- (progn
- (set-syntax-table (copy-syntax-table))
- ,@body)
- (set-syntax-table ,orig-table)))))
- (eval-and-compile
- (unless (fboundp 'match-string-no-properties)
- (defun match-string-no-properties (num &optional string)
- "Return string of text matched by last search, without text properties.
- NUM specifies which parenthesized expression in the last regexp.
- Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
- Zero means the entire text matched by the whole regexp or whole string.
- STRING should be given if the last search was by `string-match' on STRING."
- (if (match-beginning num)
- (if string
- (let ((result
- (substring string (match-beginning num) (match-end num))))
- (set-text-properties 0 (length result) nil result)
- result)
- (buffer-substring-no-properties (match-beginning num)
- (match-end num)))))))
- (unless (fboundp 'line-beginning-position)
- (if (fboundp 'point-at-bol)
- (defalias 'line-beginning-position 'point-at-bol)
- (defun line-beginning-position (&optional N)
- "Return the character position of the first character on the current line.
- With argument N not nil or 1, move forward N - 1 lines first. If scan
- reaches end of buffer, return that position."
- (save-excursion
- (forward-line (if N (1- N) 0))
- (point)))))
- (mode-info-static-if (featurep 'xemacs)
- (defalias 'mode-info-key-or-menu-binding 'key-or-menu-binding)
- (defun mode-info-key-or-menu-binding (key)
- "Return the binding for command KEY in current keymaps."
- (save-excursion
- (let ((modifiers (event-modifiers (aref key 0)))
- window position)
- (when (or (memq 'click modifiers)
- (memq 'down modifiers)
- (memq 'drag modifiers))
- (setq window (posn-window (event-start (aref key 0)))
- position (posn-point (event-start (aref key 0)))))
- (when (windowp window)
- (set-buffer (window-buffer window))
- (goto-char position))
- (mode-info-static-if (fboundp 'string-key-binding)
- (or (string-key-binding key) (key-binding key))
- (key-binding key))))))
- ;;; Object System:
- (eval-and-compile
- (defvar mode-info-obarray
- (let ((obarray (make-vector 31 0)))
- (intern "mode-info" obarray) ;; mode-info means the base object.
- obarray)
- "Table of mode-info-classes.")
- (defvar mode-info-method-obarray (make-vector 63 0)
- "Method table of mode-info-classes."))
- (defconst mode-info-prefix "mode-info-")
- (defmacro mode-info-defclass (class &rest parents)
- "Define CLASS as a mode-info-class."
- `(eval-and-compile
- (mode-info-defclass-1 (quote ,class) (quote ,parents))))
- (eval-and-compile
- (defmacro mode-info-parents (class)
- "Return parents of CLASS."
- `(get ,class '*parents*)))
- (defun mode-info-defclass-1 (class parents)
- (setf (mode-info-parents
- (setq class (intern (symbol-name class) mode-info-obarray)))
- (append
- (mapcar (lambda (p)
- (intern (symbol-name p) mode-info-obarray))
- parents)
- '(mode-info)))
- class)
- (defmacro mode-info-method-symbol-name (method class)
- "Generate a unique name from METHOD and CLASS."
- `(concat (symbol-name ,class) "@" (symbol-name ,method)))
- (defun mode-info-find-class (name)
- "Return class has NAME."
- (intern-soft (if (symbolp name) (symbol-name name) name)
- mode-info-obarray))
- (defmacro mode-info-class (entity)
- "Return class of ENTITY."
- `(intern-soft (symbol-name ,entity) mode-info-obarray))
- (defun mode-info-class-name (class)
- "Return the CLASS name."
- (symbol-name class))
- (defun mode-info-method-search (name class)
- "Search the method which is named NAME for CLASS."
- (or (intern-soft (mode-info-method-symbol-name name class)
- mode-info-method-obarray)
- (let ((method)
- (classes (mode-info-parents class)))
- (while (and (not method) classes)
- (setq method
- (mode-info-method-search name (pop classes))))
- method)))
- (put 'mode-info-void-method 'error-conditions
- '(error void-function mode-info-void-method))
- (put 'mode-info-void-method 'error-message
- "Symbol's method definition is void")
- (put 'mode-info-defgeneric 'lisp-indent-function 'defun)
- (defmacro mode-info-defgeneric (name args &optional document)
- "Define a function NAME that provides a generic interface to the method NAME.
- ARGS is the argument list for NAME. The first element of ARGS is an
- entity."
- `(defun ,(intern (concat mode-info-prefix (symbol-name name))) ,args
- ,@(if document (list document) nil)
- (let ((method (mode-info-method-search
- (quote ,name) (mode-info-class ,(car args)))))
- (if method
- (,(if (memq '&rest args)
- 'apply
- 'funcall)
- method
- ,@(delq '&rest (delq '&optional (copy-sequence args))))
- (signal 'mode-info-void-method
- (make-symbol
- (mode-info-method-symbol-name (quote ,name)
- ,(car args))))))))
- (eval-and-compile
- (defun mode-info-method-search-next (name class)
- "Search the next method which is named NAME for CLASS."
- (let ((method)
- (classes (mode-info-parents class)))
- (while (and (not method) classes)
- (setq method (mode-info-method-search name (pop classes))))
- method)))
- (put 'mode-info-defmethod 'lisp-indent-function 'defun)
- (put 'mode-info-defmethod 'edebug-form-spec
- '(&define name
- ((arg symbolp)
- [&rest arg]
- [&optional ["&optional" arg &rest arg]]
- &optional ["&rest" arg])
- [&optional stringp]
- [&optional ("interactive" interactive)]
- def-body))
- (defmacro mode-info-defmethod (name spec &rest body)
- "Define NAME as a method of a mode-info-class."
- (let* ((class (nth 1 (car spec)))
- (args (cons (caar spec) (cdr spec)))
- (next (mode-info-method-search-next name (mode-info-class class))))
- `(fset (intern (eval-when-compile
- (mode-info-method-symbol-name (quote ,name)
- (quote ,class)))
- mode-info-method-obarray)
- ,(if next
- `(function
- (lambda ,args
- (labels ((mode-info-method-next
- nil
- (,(if (memq '&rest args)
- 'apply
- 'funcall)
- (intern ,(symbol-name next)
- mode-info-method-obarray)
- ,@(delq '&rest (delq '&optional
- (copy-sequence args))))))
- ,@body)))
- `(function (lambda ,args ,@body))))))
- (defun mode-info-method-next (&rest args)
- "Call the next method in the current method function.
- IMPORTANT NOTICE: It is disabled using this function out of methods."
- (signal 'mode-info-void-method nil))
- (provide 'mi-util)
- ;;; mi-util.el ends here