Hi David,
> Eric and I got the same idea to use special symbol properties to drive
> semantic-elisp-use-read, instead of a hard coded `cond' clause.
>
> Unfortunately we haven't had free time enough yet to work on that :-(
Well, i have not really much time but in the meanwhile this hard-code
cond is boring me ;-)
So here is a code which gives you a smart and easy to customize
elisp-parser...just replace the existing semantic-elisp-use-read
with the following code.
Especially read the very detailed docstring of semantic-elisp-set-tagger
where i have tried to explain the new feature as best as possible ;-)
A review would be nice.
----- code begin ------
(defun semantic-elisp-set-tagger (symbol-or-list tag-gen-fcn)
"Define a tag-generation-function for certain symbols.
SYMBOL-OR-LIST is either a symbol or a list of symbol for which TAG-GEN-FCN is
called to generate an appropriate semantic-tag. This function \"tells\"
semantic how to generate such a tag for a certain symbol, e.g. how to generate
a function-tag when the `defun'-keyword is found in an elisp-sourcebuffer.
TAG-GEN-FCN is either a function or a symbol. If a function use that function
to generate the semantic-tag for SYMBOL-OR-LIST. If a symbol then semantic
first checks if is a function-symbol which has not set an own TAG-GEN-FCN. If
this is the case then use that function to generate the semantic-tag for the
symbol\(s) of SYMBOL-OR-LIST. Otherwise looks for the tag-generation-function
of the TAG-GEN-FCN-symbol and uses that to generate the semantic tag. This is a
recursive mechanism so a \"chain\" of symbols can be defined wheres only for
the first symbol a tag-generation-function is set and all \"subsequent\"
symbols are defined to use the tag-generation-function of that symbol.
Example 1:
\(semantic-elisp-set-tagger 'defun \(lambda \(a b c) <return tag>))
\(semantic-elisp-set-tagger 'defsubst 'defun)
\(semantic-elisp-set-tagger 'defmacro 'defsubst)
With these settings for all three symbols 'defun, 'defsubst and 'defmacro
the lambda-expression defined for 'defun is used as tag-generation-function.
Example 2:
\(defun my-gen-tag-for-function \(a b c)
<return a semantic-tag>)
\(semantic-elisp-set-tagger '\(defun defsubst)
'my-gen-tag-for-function)
With these settings for 'defun and 'defsubst the function
my-gen-tag-for-function is used as tag-generation-function.
TAG-GEN-FCN will be called with three args: First arg is the whole lisp-object
read by the parser, so e.g. a whole defun-sexp. Second arg is the car of this
lisp-object, which will mostly be the keyword-symbol, e.g. 'defun. Third arg
is the name following this keyword-symbol as string, e.g. the name of the
function when the first arg is a defun-sexp.
TAG-GEN-FCN has to return a valid semantic-tag.
With this function user-defined elisp-keywords can be added to the
elisp-parser of semantic. This can be done like follows:
Suppose there is a new keyword 'def-myspecial for which a
semantic-function-tag should be generated. Then do for example:
\(eval-after-load \"semantic-el\"
\(semantic-elisp-set-tagger 'def-myspecial
\(lambda \(read-lobject keyword-symbol name-after-keyword)
\(semantic-tag-new-function .....))))"
(setq symbol-or-list (if (listp symbol-or-list)
symbol-or-list
(list symbol-or-list)))
(dolist (sym symbol-or-list)
(put sym 'semantic-elisp-tag-gen-fcn tag-gen-fcn)))
(defun semantic-elisp-get-tagger (symbol)
"Return the tag-generation-function defined for SYMBOL. If no one can be
found for SYMBOL then return nil. See also `semantic-elisp-set-tagger' for a
description of the recursive mechanism."
(let ((result (get symbol 'semantic-elisp-tag-gen-fcn)))
(cond ((null result)
nil)
((and (functionp result)
(not (and (symbolp result)
(get result 'semantic-elisp-tag-gen-fcn))))
result)
((symbolp result)
(semantic-elisp-get-tagger result))
(t nil))))
(defun semantic-elisp-use-read (sl)
"Use `read' on the semantic list SL.
Return a bovination list to use."
(let* ((read-lobject (read (buffer-substring (car sl) (cdr sl)))) ; read text
(keyword-symbol (car read-lobject)) ; type symbol
(tss (nth 1 read-lobject))
(ss (cond ((stringp tss) (intern tss))
((not (listp tss)) tss)
(t (if (eq (car tss) 'quote)
(nth 1 tss)
(car tss)))))
(name-after-keyword (format "%S" ss))
)
(cond
((listp keyword-symbol)
;; If the first elt is a list, then it is some arbitrary code.
(semantic-tag-new-code "anonymous" nil))
((memq keyword-symbol '(eval-and-compile 'eval-when-compile))
;; Eval and compile can be wrapped around definitions, such as in
;; eieio.el, so splice it's parts back into the main list.
(condition-case foo
(semantic-parse-region (car sl) (cdr sl) nil 1)
(error (message "MUNGE: %S" foo)
nil))
)
((symbolp keyword-symbol)
;; Now generate tags for all symbols for which a tagger is set by
;; `semantic-elisp-set-tagger'
(let ((tagger (semantic-elisp-get-tagger keyword-symbol)))
(if (functionp tagger)
(funcall tagger read-lobject keyword-symbol name-after-keyword)
(semantic-tag-new-code (symbol-name keyword-symbol) nil)))))))
;; now we set the taggers
;; TODO: Klaus Berndl <klaus.berndl@...>: Maybe we could define a small but
;; conveniant helper-macro which encapsulates this ugly
;; (semantic-elisp-set-tagger
;; '(sym1 sym2 ... sym3)
;; (function (lambda (read-lobject keyword-symbol name-after-keyword)
;; which is needed for each tagger-setting...but maybe later ;-)
;; Variables and constants
;; To avoid font-locking for the symbols we define first only 'defvar and then
;; add for each of the rest an own semantic-elisp-set-tagger 'XXX. instead of
;; (semantic-elisp-set-tagger '(defvar defconst...)...)
(semantic-elisp-set-tagger
'defvar
(function (lambda (read-lobject keyword-symbol name-after-keyword)
(let ((doc (semantic-elisp-form-to-doc-string (nth 3 read-lobject))))
(semantic-tag-new-variable
name-after-keyword nil (nth 2 read-lobject)
:user-visible-flag (and doc
(> (length doc) 0)
(= (aref doc 0) ?*))
:constant-flag (if (eq keyword-symbol 'defconst) t nil)
:documentation (semantic-elisp-do-doc doc)
)))))
(semantic-elisp-set-tagger 'defconst 'defvar)
(semantic-elisp-set-tagger 'defcustom 'defvar)
(semantic-elisp-set-tagger 'defface 'defvar)
(semantic-elisp-set-tagger 'defimage 'defvar)
;; functions and macros
(semantic-elisp-set-tagger
'defun
(function (lambda (read-lobject keyword-symbol name-after-keyword)
(semantic-tag-new-function
name-after-keyword nil (semantic-elisp-desymbolify (nth 2 read-lobject))
:user-visible-flag (equal (car-safe (nth 4 read-lobject)) 'interactive)
:documentation (semantic-elisp-do-doc (nth 3 read-lobject))
:overloadable (eq keyword-symbol 'define-overload)
))))
(semantic-elisp-set-tagger 'defun* 'defun)
(semantic-elisp-set-tagger 'defsubst 'defun)
(semantic-elisp-set-tagger 'defmacro 'defun)
(semantic-elisp-set-tagger 'define-overload 'defun)
;; autoload
(semantic-elisp-set-tagger
'autoload
(function (lambda (read-lobject keyword-symbol name-after-keyword)
(semantic-tag-new-function
(format "%S" (car (cdr (car (cdr read-lobject)))))
nil nil
:user-visible-flag (and (nth 4 read-lobject)
(not (eq (nth 4 read-lobject) 'nil)))
:prototype-flag t
:documentation (semantic-elisp-do-doc (nth 3 read-lobject)))
)))
;; defgeneric and defmethod
(semantic-elisp-set-tagger
'defmethod
(function (lambda (read-lobject keyword-symbol name-after-keyword)
;; methods
(let* ((a2 (nth 2 read-lobject))
(a3 (nth 3 read-lobject))
(args (if (listp a2) a2 a3))
(doc (nth (if (listp a2) 3 4) read-lobject)))
(semantic-tag-new-function
name-after-keyword nil
(if (listp (car args))
(cons (symbol-name (car (car args)))
(semantic-elisp-desymbolify (cdr args)))
(semantic-elisp-desymbolify (cdr args)))
:parent (symbol-name
(if (listp (car args)) (car (cdr (car args)))))
:documentation (semantic-elisp-do-doc doc)
)))))
(semantic-elisp-set-tagger 'defgeneric 'defmethod)
;; Advice
(semantic-elisp-set-tagger
'defadvice
(function (lambda (read-lobject keyword-symbol name-after-keyword)
(semantic-tag-new-function
name-after-keyword nil (semantic-elisp-desymbolify
(nth 2 read-lobject))
))))
;; defclass
(semantic-elisp-set-tagger
'defclass
(function (lambda (read-lobject keyword-symbol name-after-keyword)
(let ((docpart (nthcdr 4 read-lobject)))
(semantic-tag-new-type
name-after-keyword "class"
(semantic-elisp-clos-args-to-semantic (nth 3 read-lobject))
(semantic-elisp-desymbolify (nth 2 read-lobject))
:typemodifiers (semantic-elisp-desymbolify
(if (not (stringp docpart))
docpart))
:documentation
(semantic-elisp-do-doc
(if (stringp (car docpart))
(car docpart)
(car (cdr (member :documentation docpart)))))
)))))
;; defstruct
(semantic-elisp-set-tagger
'defstruct
(function (lambda (read-lobject keyword-symbol name-after-keyword)
(semantic-tag-new-type
name-after-keyword "struct" (semantic-elisp-desymbolify (nthcdr 2 read-lobject))
nil ;(semantic-elisp-desymbolify (nth 2 read-lobject))
)
;; (nth 4 read-lobject) doc string
)))
;; Now about a few Semantic specials?
(semantic-elisp-set-tagger
'define-lex
(function (lambda (read-lobject keyword-symbol name-after-keyword)
(semantic-tag-new-function
name-after-keyword nil nil
:lexical-analyzer-flag t
:documentation (semantic-elisp-do-doc (nth 2 read-lobject))
))))
(semantic-elisp-set-tagger
'(define-mode-overload-implementation define-mode-local-override)
(function (lambda (read-lobject keyword-symbol name-after-keyword)
(let ((args (nth 3 read-lobject)))
(semantic-tag-new-function
name-after-keyword nil
(when (listp args) (semantic-elisp-desymbolify args))
:override-function-flag t
:parent (format "%S" (nth 2 read-lobject))
:documentation (semantic-elisp-do-doc (nth 4 read-lobject))
)))))
(semantic-elisp-set-tagger
'defvar-mode-local
(function (lambda (read-lobject keyword-symbol name-after-keyword)
(semantic-tag-new-variable
(format "%S" (nth 2 read-lobject)) nil
(nth 3 read-lobject) ; default value
:override-variable-flag t
:parent name-after-keyword
:documentation (semantic-elisp-do-doc (nth 4 read-lobject))
))))
;; Now for other stuff
(semantic-elisp-set-tagger
'require
(function (lambda (read-lobject keyword-symbol name-after-keyword)
(semantic-tag-new-include
name-after-keyword nil :directory (nth 2 read-lobject)))))
(semantic-elisp-set-tagger
'provide
(function (lambda (read-lobject keyword-symbol name-after-keyword)
(semantic-tag-new-package
name-after-keyword (nth 3 read-lobject)))))
------ code end ----------
Thoughts, enhancements etc... to this code?
If you do not object then i would commit it.
Ciao,
Klaus
P.S.
This is how ECB uses this new code:
(when (fboundp 'semantic-elisp-set-tagger)
(eval-after-load "semantic-el"
(progn
;; defecb-multicache
(semantic-elisp-set-tagger 'defecb-multicache 'defvar)
;; defecb-stealthy and tree-buffer-defpopup-command
(semantic-elisp-set-tagger
'defecb-stealthy
(function
(lambda (read-lobject keyword-symbol name-after-keyword)
(semantic-tag-new-function
name-after-keyword nil nil
:user-visible-flag nil
:documentation (semantic-elisp-do-doc (nth 2 read-lobject))))))
(semantic-elisp-set-tagger 'tree-buffer-defpopup-command 'defecb-stealthy)
;; ecb-layout-define
(semantic-elisp-set-tagger
'ecb-layout-define
(function
(lambda (read-lobject keyword-symbol name-after-keyword)
(semantic-tag-new-function
name-after-keyword nil
(semantic-elisp-desymbolify (list (nth 2 read-lobject)))
:user-visible-flag nil
:documentation (semantic-elisp-do-doc (nth 3 read-lobject)))))))))
|