Commit | Line | Data |
---|---|---|
4feec2f5 CY |
1 | ;;; semantic/bovine/el.el --- Semantic details for Emacs Lisp |
2 | ||
3 | ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, | |
4 | ;;; 2008, 2009 Free Software Foundation, Inc. | |
5 | ||
6 | ;; Author: Eric M. Ludlam <zappo@gnu.org> | |
7 | ||
8 | ;; This file is part of GNU Emacs. | |
9 | ||
10 | ;; GNU Emacs is free software: you can redistribute it and/or modify | |
11 | ;; it under the terms of the GNU General Public License as published by | |
12 | ;; the Free Software Foundation, either version 3 of the License, or | |
13 | ;; (at your option) any later version. | |
14 | ||
15 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;; GNU General Public License for more details. | |
19 | ||
20 | ;; You should have received a copy of the GNU General Public License | |
21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | |
22 | ||
23 | ;;; Commentary: | |
24 | ;; | |
25 | ;; Use the Semantic Bovinator for Emacs Lisp | |
26 | ||
27 | (require 'semantic) | |
28 | (require 'semantic/bovine) | |
29 | (require 'find-func) | |
30 | ||
31 | (require 'semantic/ctxt) | |
32 | (require 'semantic/format) | |
33 | (require 'thingatpt) | |
34 | ||
35 | ;;; Code: | |
36 | \f | |
37 | ;;; Lexer | |
38 | ;; | |
39 | (define-lex semantic-emacs-lisp-lexer | |
40 | "A simple lexical analyzer for Emacs Lisp. | |
41 | This lexer ignores comments and whitespace, and will return | |
42 | syntax as specified by the syntax table." | |
43 | semantic-lex-ignore-whitespace | |
44 | semantic-lex-ignore-newline | |
45 | semantic-lex-number | |
46 | semantic-lex-symbol-or-keyword | |
47 | semantic-lex-charquote | |
48 | semantic-lex-paren-or-list | |
49 | semantic-lex-close-paren | |
50 | semantic-lex-string | |
51 | semantic-lex-ignore-comments | |
52 | semantic-lex-punctuation | |
53 | semantic-lex-default-action) | |
54 | \f | |
55 | ;;; Parser | |
56 | ;; | |
57 | (defvar semantic--elisp-parse-table | |
58 | `((bovine-toplevel | |
59 | (semantic-list | |
60 | ,(lambda (vals start end) | |
61 | (let ((tag (semantic-elisp-use-read (car vals)))) | |
62 | (cond | |
63 | ((and (listp tag) (semantic-tag-p (car tag))) | |
64 | ;; We got a list of tags back. This list is | |
65 | ;; returned here in the correct order, but this | |
66 | ;; list gets reversed later, putting the correctly ordered | |
67 | ;; items into reverse order later. | |
68 | (nreverse tag)) | |
69 | ((semantic--tag-expanded-p tag) | |
70 | ;; At this point, if `semantic-elisp-use-read' returned an | |
71 | ;; already expanded tag (from definitions parsed inside an | |
72 | ;; eval and compile wrapper), just pass it! | |
73 | tag) | |
74 | (t | |
75 | ;; We got the basics of a single tag. | |
76 | (append tag (list start end)))))))) | |
77 | ) | |
78 | "Top level bovination table for elisp.") | |
79 | ||
80 | (defun semantic-elisp-desymbolify (arglist) | |
81 | "Convert symbols to strings for ARGLIST." | |
82 | (let ((out nil)) | |
83 | (while arglist | |
84 | (setq out | |
85 | (cons | |
86 | (if (symbolp (car arglist)) | |
87 | (symbol-name (car arglist)) | |
88 | (if (and (listp (car arglist)) | |
89 | (symbolp (car (car arglist)))) | |
90 | (symbol-name (car (car arglist))) | |
91 | (format "%S" (car arglist)))) | |
92 | out) | |
93 | arglist (cdr arglist))) | |
94 | (nreverse out))) | |
95 | ||
96 | (defun semantic-elisp-desymbolify-args (arglist) | |
97 | "Convert symbols to strings for ARGLIST." | |
98 | (let ((in (semantic-elisp-desymbolify arglist)) | |
99 | (out nil)) | |
100 | (dolist (T in) | |
101 | (when (not (string-match "^&" T)) | |
102 | (push T out))) | |
103 | (nreverse out))) | |
104 | ||
105 | (defun semantic-elisp-clos-slot-property-string (slot property) | |
106 | "For SLOT, a string representing PROPERTY." | |
107 | (let ((p (member property slot))) | |
108 | (if (not p) | |
109 | nil | |
110 | (setq p (cdr p)) | |
111 | (cond | |
112 | ((stringp (car p)) | |
113 | (car p)) | |
114 | ((or (symbolp (car p)) | |
115 | (listp (car p)) | |
116 | (numberp (car p))) | |
117 | (format "%S" (car p))) | |
118 | (t nil))))) | |
119 | ||
120 | (defun semantic-elisp-clos-args-to-semantic (partlist) | |
121 | "Convert a list of CLOS class slot PARTLIST to `variable' tags." | |
122 | (let (vars part v) | |
123 | (while partlist | |
124 | (setq part (car partlist) | |
125 | partlist (cdr partlist) | |
126 | v (semantic-tag-new-variable | |
127 | (symbol-name (car part)) | |
128 | (semantic-elisp-clos-slot-property-string part :type) | |
129 | (semantic-elisp-clos-slot-property-string part :initform) | |
130 | ;; Attributes | |
131 | :protection (semantic-elisp-clos-slot-property-string | |
132 | part :protection) | |
133 | :static-flag (equal (semantic-elisp-clos-slot-property-string | |
134 | part :allocation) | |
135 | ":class") | |
136 | :documentation (semantic-elisp-clos-slot-property-string | |
137 | part :documentation)) | |
138 | vars (cons v vars))) | |
139 | (nreverse vars))) | |
140 | ||
141 | (defun semantic-elisp-form-to-doc-string (form) | |
142 | "After reading a form FORM, covert it to a doc string. | |
143 | For Emacs Lisp, sometimes that string is non-existant. | |
144 | Sometimes it is a form which is evaluated at compile time, permitting | |
145 | compound strings." | |
146 | (cond ((stringp form) form) | |
147 | ((and (listp form) (eq (car form) 'concat) | |
148 | (stringp (nth 1 form))) | |
149 | (nth 1 form)) | |
150 | (t nil))) | |
151 | ||
152 | (defvar semantic-elisp-store-documentation-in-tag nil | |
153 | "*When non-nil, store documentation strings in the created tags.") | |
154 | ||
155 | (defun semantic-elisp-do-doc (str) | |
156 | "Return STR as a documentation string IF they are enabled." | |
157 | (when semantic-elisp-store-documentation-in-tag | |
158 | (semantic-elisp-form-to-doc-string str))) | |
159 | ||
160 | (defmacro semantic-elisp-setup-form-parser (parser &rest symbols) | |
161 | "Install the function PARSER as the form parser for SYMBOLS. | |
162 | SYMBOLS is a list of symbols identifying the forms to parse. | |
163 | PARSER is called on every forms whose first element (car FORM) is | |
164 | found in SYMBOLS. It is passed the parameters FORM, START, END, | |
165 | where: | |
166 | ||
167 | - FORM is an Elisp form read from the current buffer. | |
168 | - START and END are the beginning and end location of the | |
169 | corresponding data in the current buffer." | |
170 | (let ((sym (make-symbol "sym"))) | |
171 | `(dolist (,sym ',symbols) | |
172 | (put ,sym 'semantic-elisp-form-parser #',parser)))) | |
173 | (put 'semantic-elisp-setup-form-parser 'lisp-indent-function 1) | |
174 | ||
175 | (defmacro semantic-elisp-reuse-form-parser (symbol &rest symbols) | |
176 | "Reuse the form parser of SYMBOL for forms identified by SYMBOLS. | |
177 | See also `semantic-elisp-setup-form-parser'." | |
178 | (let ((parser (make-symbol "parser")) | |
179 | (sym (make-symbol "sym"))) | |
180 | `(let ((,parser (get ',symbol 'semantic-elisp-form-parser))) | |
181 | (or ,parser | |
182 | (signal 'wrong-type-argument | |
183 | '(semantic-elisp-form-parser ,symbol))) | |
184 | (dolist (,sym ',symbols) | |
185 | (put ,sym 'semantic-elisp-form-parser ,parser))))) | |
186 | ||
187 | (defun semantic-elisp-use-read (sl) | |
188 | "Use `read' on the semantic list SL. | |
189 | Return a bovination list to use." | |
190 | (let* ((start (car sl)) | |
191 | (end (cdr sl)) | |
192 | (form (read (buffer-substring-no-properties start end)))) | |
193 | (cond | |
194 | ;; If the first elt is a list, then it is some arbitrary code. | |
195 | ((listp (car form)) | |
196 | (semantic-tag-new-code "anonymous" nil) | |
197 | ) | |
198 | ;; A special form parser is provided, use it. | |
199 | ((and (car form) (symbolp (car form)) | |
200 | (get (car form) 'semantic-elisp-form-parser)) | |
201 | (funcall (get (car form) 'semantic-elisp-form-parser) | |
202 | form start end)) | |
203 | ;; Produce a generic code tag by default. | |
204 | (t | |
205 | (semantic-tag-new-code (format "%S" (car form)) nil) | |
206 | )))) | |
207 | \f | |
208 | ;;; Form parsers | |
209 | ;; | |
210 | (semantic-elisp-setup-form-parser | |
211 | (lambda (form start end) | |
212 | (semantic-tag-new-function | |
213 | (symbol-name (nth 2 form)) | |
214 | nil | |
215 | '("form" "start" "end") | |
216 | :form-parser t | |
217 | )) | |
218 | semantic-elisp-setup-form-parser) | |
219 | ||
220 | (semantic-elisp-setup-form-parser | |
221 | (lambda (form start end) | |
222 | (let ((tags | |
223 | (condition-case foo | |
224 | (semantic-parse-region start end nil 1) | |
225 | (error (message "MUNGE: %S" foo) | |
226 | nil)))) | |
227 | (if (semantic-tag-p (car-safe tags)) | |
228 | tags | |
229 | (semantic-tag-new-code (format "%S" (car form)) nil)))) | |
230 | eval-and-compile | |
231 | eval-when-compile | |
232 | ) | |
233 | ||
234 | (semantic-elisp-setup-form-parser | |
235 | (lambda (form start end) | |
236 | (semantic-tag-new-function | |
237 | (symbol-name (nth 1 form)) | |
238 | nil | |
239 | (semantic-elisp-desymbolify-args (nth 2 form)) | |
240 | :user-visible-flag (eq (car-safe (nth 4 form)) 'interactive) | |
241 | :documentation (semantic-elisp-do-doc (nth 3 form)) | |
242 | :overloadable (or (eq (car form) 'define-overload) | |
243 | (eq (car form) 'define-overloadable-function)) | |
244 | )) | |
245 | defun | |
246 | defun* | |
247 | defsubst | |
248 | defmacro | |
249 | define-overload ;; @todo - remove after cleaning up semantic. | |
250 | define-overloadable-function | |
251 | ) | |
252 | ||
253 | (semantic-elisp-setup-form-parser | |
254 | (lambda (form start end) | |
255 | (let ((doc (semantic-elisp-form-to-doc-string (nth 3 form)))) | |
256 | (semantic-tag-new-variable | |
257 | (symbol-name (nth 1 form)) | |
258 | nil | |
259 | (nth 2 form) | |
260 | :user-visible-flag (and doc | |
261 | (> (length doc) 0) | |
262 | (= (aref doc 0) ?*)) | |
263 | :constant-flag (eq (car form) 'defconst) | |
264 | :documentation (semantic-elisp-do-doc doc) | |
265 | ))) | |
266 | defvar | |
267 | defconst | |
268 | defcustom | |
269 | ) | |
270 | ||
271 | (semantic-elisp-setup-form-parser | |
272 | (lambda (form start end) | |
273 | (let ((doc (semantic-elisp-form-to-doc-string (nth 3 form)))) | |
274 | (semantic-tag-new-variable | |
275 | (symbol-name (nth 1 form)) | |
276 | "face" | |
277 | (nth 2 form) | |
278 | :user-visible-flag (and doc | |
279 | (> (length doc) 0) | |
280 | (= (aref doc 0) ?*)) | |
281 | :documentation (semantic-elisp-do-doc doc) | |
282 | ))) | |
283 | defface | |
284 | ) | |
285 | ||
286 | ||
287 | (semantic-elisp-setup-form-parser | |
288 | (lambda (form start end) | |
289 | (let ((doc (semantic-elisp-form-to-doc-string (nth 3 form)))) | |
290 | (semantic-tag-new-variable | |
291 | (symbol-name (nth 1 form)) | |
292 | "image" | |
293 | (nth 2 form) | |
294 | :user-visible-flag (and doc | |
295 | (> (length doc) 0) | |
296 | (= (aref doc 0) ?*)) | |
297 | :documentation (semantic-elisp-do-doc doc) | |
298 | ))) | |
299 | defimage | |
300 | defezimage | |
301 | ) | |
302 | ||
303 | ||
304 | (semantic-elisp-setup-form-parser | |
305 | (lambda (form start end) | |
306 | (let ((doc (semantic-elisp-form-to-doc-string (nth 3 form)))) | |
307 | (semantic-tag | |
308 | (symbol-name (nth 1 form)) | |
309 | 'customgroup | |
310 | :value (nth 2 form) | |
311 | :user-visible-flag t | |
312 | :documentation (semantic-elisp-do-doc doc) | |
313 | ))) | |
314 | defgroup | |
315 | ) | |
316 | ||
317 | ||
318 | (semantic-elisp-setup-form-parser | |
319 | (lambda (form start end) | |
320 | (semantic-tag-new-function | |
321 | (symbol-name (cadr (cadr form))) | |
322 | nil nil | |
323 | :user-visible-flag (and (nth 4 form) | |
324 | (not (eq (nth 4 form) 'nil))) | |
325 | :prototype-flag t | |
326 | :documentation (semantic-elisp-do-doc (nth 3 form)))) | |
327 | autoload | |
328 | ) | |
329 | ||
330 | (semantic-elisp-setup-form-parser | |
331 | (lambda (form start end) | |
332 | (let* ((a2 (nth 2 form)) | |
333 | (a3 (nth 3 form)) | |
334 | (args (if (listp a2) a2 a3)) | |
335 | (doc (nth (if (listp a2) 3 4) form))) | |
336 | (semantic-tag-new-function | |
337 | (symbol-name (nth 1 form)) | |
338 | nil | |
339 | (if (listp (car args)) | |
340 | (cons (symbol-name (caar args)) | |
341 | (semantic-elisp-desymbolify-args (cdr args))) | |
342 | (semantic-elisp-desymbolify-args (cdr args))) | |
343 | :parent (if (listp (car args)) (symbol-name (cadr (car args))) nil) | |
344 | :documentation (semantic-elisp-do-doc doc) | |
345 | ))) | |
346 | defmethod | |
347 | defgeneric | |
348 | ) | |
349 | ||
350 | (semantic-elisp-setup-form-parser | |
351 | (lambda (form start end) | |
352 | (semantic-tag-new-function | |
353 | (symbol-name (nth 1 form)) | |
354 | nil | |
355 | (semantic-elisp-desymbolify (nth 2 form)) | |
356 | )) | |
357 | defadvice | |
358 | ) | |
359 | ||
360 | (semantic-elisp-setup-form-parser | |
361 | (lambda (form start end) | |
362 | (let ((docpart (nthcdr 4 form))) | |
363 | (semantic-tag-new-type | |
364 | (symbol-name (nth 1 form)) | |
365 | "class" | |
366 | (semantic-elisp-clos-args-to-semantic (nth 3 form)) | |
367 | (semantic-elisp-desymbolify (nth 2 form)) | |
368 | :typemodifiers (semantic-elisp-desymbolify | |
369 | (unless (stringp (car docpart)) docpart)) | |
370 | :documentation (semantic-elisp-do-doc | |
371 | (if (stringp (car docpart)) | |
372 | (car docpart) | |
373 | (cadr (member :documentation docpart)))) | |
374 | ))) | |
375 | defclass | |
376 | ) | |
377 | ||
378 | (semantic-elisp-setup-form-parser | |
379 | (lambda (form start end) | |
380 | (let ((slots (nthcdr 2 form))) | |
381 | ;; Skip doc string if present. | |
382 | (and (stringp (car slots)) | |
383 | (setq slots (cdr slots))) | |
384 | (semantic-tag-new-type | |
385 | (symbol-name (if (consp (nth 1 form)) | |
386 | (car (nth 1 form)) | |
387 | (nth 1 form))) | |
388 | "struct" | |
389 | (semantic-elisp-desymbolify slots) | |
390 | (cons nil nil) | |
391 | ))) | |
392 | defstruct | |
393 | ) | |
394 | ||
395 | (semantic-elisp-setup-form-parser | |
396 | (lambda (form start end) | |
397 | (semantic-tag-new-function | |
398 | (symbol-name (nth 1 form)) | |
399 | nil nil | |
400 | :lexical-analyzer-flag t | |
401 | :documentation (semantic-elisp-do-doc (nth 2 form)) | |
402 | )) | |
403 | define-lex | |
404 | ) | |
405 | ||
406 | (semantic-elisp-setup-form-parser | |
407 | (lambda (form start end) | |
408 | (let ((args (nth 3 form))) | |
409 | (semantic-tag-new-function | |
410 | (symbol-name (nth 1 form)) | |
411 | nil | |
412 | (and (listp args) (semantic-elisp-desymbolify args)) | |
413 | :override-function-flag t | |
414 | :parent (symbol-name (nth 2 form)) | |
415 | :documentation (semantic-elisp-do-doc (nth 4 form)) | |
416 | ))) | |
417 | define-mode-overload-implementation ;; obsoleted | |
418 | define-mode-local-override | |
419 | ) | |
420 | ||
421 | (semantic-elisp-setup-form-parser | |
422 | (lambda (form start end) | |
423 | (semantic-tag-new-variable | |
424 | (symbol-name (nth 2 form)) | |
425 | nil | |
426 | (nth 3 form) ; default value | |
427 | :override-variable-flag t | |
428 | :parent (symbol-name (nth 1 form)) | |
429 | :documentation (semantic-elisp-do-doc (nth 4 form)) | |
430 | )) | |
431 | defvar-mode-local | |
432 | ) | |
433 | ||
434 | (semantic-elisp-setup-form-parser | |
435 | (lambda (form start end) | |
436 | (let ((name (nth 1 form))) | |
437 | (semantic-tag-new-include | |
438 | (symbol-name (if (eq (car-safe name) 'quote) | |
439 | (nth 1 name) | |
440 | name)) | |
441 | nil | |
442 | :directory (nth 2 form)))) | |
443 | require | |
444 | ) | |
445 | ||
446 | (semantic-elisp-setup-form-parser | |
447 | (lambda (form start end) | |
448 | (let ((name (nth 1 form))) | |
449 | (semantic-tag-new-package | |
450 | (symbol-name (if (eq (car-safe name) 'quote) | |
451 | (nth 1 name) | |
452 | name)) | |
453 | (nth 3 form)))) | |
454 | provide | |
455 | ) | |
456 | \f | |
457 | ;;; Mode setup | |
458 | ;; | |
459 | (define-mode-local-override semantic-dependency-tag-file | |
460 | emacs-lisp-mode (tag) | |
461 | "Find the file BUFFER depends on described by TAG." | |
462 | (if (fboundp 'find-library-name) | |
463 | (condition-case nil | |
464 | ;; Try an Emacs 22 fcn. This throws errors. | |
465 | (find-library-name (semantic-tag-name tag)) | |
466 | (error | |
467 | (message "semantic: connot find source file %s" | |
468 | (semantic-tag-name tag)))) | |
469 | ;; No handy function available. (Older Emacsen) | |
470 | (let* ((lib (locate-library (semantic-tag-name tag))) | |
471 | (name (if lib (file-name-sans-extension lib) nil)) | |
472 | (nameel (concat name ".el"))) | |
473 | (cond | |
474 | ((and name (file-exists-p nameel)) nameel) | |
475 | ((and name (file-exists-p (concat name ".el.gz"))) | |
476 | ;; This is the linux distro case. | |
477 | (concat name ".el.gz")) | |
478 | ;; source file does not exists | |
479 | (name | |
480 | (message "semantic: cannot find source file %s" (concat name ".el"))) | |
481 | (t | |
482 | nil))))) | |
483 | ||
484 | ;;; DOC Strings | |
485 | ;; | |
486 | (defun semantic-emacs-lisp-overridable-doc (tag) | |
487 | "Return the documentation string generated for overloadable functions. | |
488 | Fetch the item for TAG. Only returns info about what symbols can be | |
489 | used to perform the override." | |
490 | (if (and (eq (semantic-tag-class tag) 'function) | |
491 | (semantic-tag-get-attribute tag :overloadable)) | |
492 | ;; Calc the doc to use for the overloadable symbols. | |
493 | (overload-docstring-extension (intern (semantic-tag-name tag))) | |
494 | "")) | |
495 | ||
496 | (defun semantic-emacs-lisp-obsoleted-doc (tag) | |
497 | "Indicate that TAG is a new name that has obsoleted some old name. | |
498 | Unfortunately, this requires that the tag in question has been loaded | |
499 | into Emacs Lisp's memory." | |
500 | (let ((obsoletethis (intern-soft (semantic-tag-name tag))) | |
501 | (obsoletor nil)) | |
502 | ;; This asks if our tag is available in the Emacs name space for querying. | |
503 | (when obsoletethis | |
504 | (mapatoms (lambda (a) | |
505 | (let ((oi (get a 'byte-obsolete-info))) | |
506 | (if (and oi (eq (car oi) obsoletethis)) | |
507 | (setq obsoletor a))))) | |
508 | (if obsoletor | |
509 | (format "\n@obsolete{%s,%s}" obsoletor (semantic-tag-name tag)) | |
510 | "")))) | |
511 | ||
512 | (define-mode-local-override semantic-documentation-for-tag | |
513 | emacs-lisp-mode (tag &optional nosnarf) | |
514 | "Return the documentation string for TAG. | |
515 | Optional argument NOSNARF is ignored." | |
516 | (let ((d (semantic-tag-docstring tag))) | |
517 | (when (not d) | |
518 | (cond ((semantic-tag-with-position-p tag) | |
519 | ;; Doc isn't in the tag itself. Lets pull it out of the | |
520 | ;; sources. | |
521 | (let ((semantic-elisp-store-documentation-in-tag t)) | |
522 | (setq tag (with-current-buffer (semantic-tag-buffer tag) | |
523 | (goto-char (semantic-tag-start tag)) | |
524 | (semantic-elisp-use-read | |
525 | ;; concoct a lexical token. | |
526 | (cons (semantic-tag-start tag) | |
527 | (semantic-tag-end tag)))) | |
528 | d (semantic-tag-docstring tag)))) | |
529 | ;; The tag may be the result of a system search. | |
530 | ((intern-soft (semantic-tag-name tag)) | |
531 | (let ((sym (intern-soft (semantic-tag-name tag)))) | |
532 | ;; Query into the global table o stuff. | |
533 | (cond ((eq (semantic-tag-class tag) 'function) | |
534 | (setq d (documentation sym))) | |
535 | (t | |
536 | (setq d (documentation-property | |
537 | sym 'variable-documentation))))) | |
538 | ;; Label it as system doc.. perhaps just for debugging | |
539 | ;; purposes. | |
540 | (if d (setq d (concat "Sytem Doc: \n" d))) | |
541 | )) | |
542 | ) | |
543 | ||
544 | (when d | |
545 | (concat | |
546 | (substitute-command-keys | |
547 | (if (and (> (length d) 0) (= (aref d 0) ?*)) | |
548 | (substring d 1) | |
549 | d)) | |
550 | (semantic-emacs-lisp-overridable-doc tag) | |
551 | (semantic-emacs-lisp-obsoleted-doc tag))))) | |
552 | ||
553 | ;;; Tag Features | |
554 | ;; | |
555 | (define-mode-local-override semantic-tag-include-filename emacs-lisp-mode | |
556 | (tag) | |
557 | "Return the name of the tag with .el appended. | |
558 | If there is a detail, prepend that directory." | |
559 | (let ((name (semantic-tag-name tag)) | |
560 | (detail (semantic-tag-get-attribute tag :directory))) | |
561 | (concat (expand-file-name name detail) ".el"))) | |
562 | ||
563 | (define-mode-local-override semantic-insert-foreign-tag | |
564 | emacs-lisp-mode (tag) | |
565 | "Insert TAG at point. | |
566 | Attempts a simple prototype for calling or using TAG." | |
567 | (cond ((semantic-tag-of-class-p tag 'function) | |
568 | (insert "(" (semantic-tag-name tag) " )") | |
569 | (forward-char -1)) | |
570 | (t | |
571 | (insert (semantic-tag-name tag))))) | |
572 | ||
573 | (define-mode-local-override semantic-tag-protection | |
574 | emacs-lisp-mode (tag &optional parent) | |
575 | "Return the protection of TAG in PARENT. | |
576 | Override function for `semantic-tag-protection'." | |
577 | (let ((prot (semantic-tag-get-attribute tag :protection))) | |
578 | (cond | |
579 | ;; If a protection is not specified, AND there is a parent | |
580 | ;; data type, then it is public. | |
581 | ((and (not prot) parent) 'public) | |
582 | ((string= prot ":public") 'public) | |
583 | ((string= prot "public") 'public) | |
584 | ((string= prot ":private") 'private) | |
585 | ((string= prot "private") 'private) | |
586 | ((string= prot ":protected") 'protected) | |
587 | ((string= prot "protected") 'protected)))) | |
588 | ||
589 | (define-mode-local-override semantic-tag-static-p | |
590 | emacs-lisp-mode (tag &optional parent) | |
591 | "Return non-nil if TAG is static in PARENT class. | |
592 | Overrides `semantic-nonterminal-static'." | |
593 | ;; This can only be true (theoretically) in a class where it is assigned. | |
594 | (semantic-tag-get-attribute tag :static-flag)) | |
595 | ||
596 | ;;; Context parsing | |
597 | ;; | |
598 | ;; Emacs lisp is very different from C,C++ which most context parsing | |
599 | ;; functions are written. Support them here. | |
600 | (define-mode-local-override semantic-up-context emacs-lisp-mode | |
601 | (&optional point bounds-type) | |
602 | "Move up one context in an Emacs Lisp function. | |
603 | A Context in many languages is a block with it's own local variables. | |
604 | In Emacs, we will move up lists and stop when one starts with one of | |
605 | the following context specifiers: | |
606 | `let', `let*', `defun', `with-slots' | |
607 | Returns non-nil it is not possible to go up a context." | |
608 | (let ((last-up (semantic-up-context-default))) | |
609 | (while | |
610 | (and (not (looking-at | |
611 | "(\\(let\\*?\\|def\\(un\\|method\\|generic\\|\ | |
612 | define-mode-overload\\)\ | |
613 | \\|with-slots\\)")) | |
614 | (not last-up)) | |
615 | (setq last-up (semantic-up-context-default))) | |
616 | last-up)) | |
617 | ||
618 | ||
619 | (define-mode-local-override semantic-ctxt-current-function emacs-lisp-mode | |
620 | (&optional point same-as-symbol-return) | |
621 | "Return a string which is the current function being called." | |
622 | (save-excursion | |
623 | (if point (goto-char point) (setq point (point))) | |
624 | ;; (semantic-beginning-of-command) | |
625 | (if (condition-case nil | |
626 | (and (save-excursion | |
627 | (up-list -2) | |
628 | (looking-at "((")) | |
629 | (save-excursion | |
630 | (up-list -3) | |
631 | (looking-at "(let"))) | |
632 | (error nil)) | |
633 | ;; This is really a let statement, not a function. | |
634 | nil | |
635 | (let ((fun (condition-case nil | |
636 | (save-excursion | |
637 | (up-list -1) | |
638 | (forward-char 1) | |
639 | (buffer-substring-no-properties | |
640 | (point) (progn (forward-sexp 1) | |
641 | (point)))) | |
642 | (error nil)) | |
643 | )) | |
644 | (when fun | |
645 | ;; Do not return FUN IFF the cursor is on FUN. | |
646 | ;; Huh? Thats because if cursor is on fun, it is | |
647 | ;; the current symbol, and not the current function. | |
648 | (if (save-excursion | |
649 | (condition-case nil | |
650 | (progn (forward-sexp -1) | |
651 | (and | |
652 | (looking-at (regexp-quote fun)) | |
653 | (<= point (+ (point) (length fun)))) | |
654 | ) | |
655 | (error t))) | |
656 | ;; Go up and try again. | |
657 | same-as-symbol-return | |
658 | ;; We are ok, so get it. | |
659 | (list fun)) | |
660 | )) | |
661 | ))) | |
662 | ||
663 | ||
664 | (define-mode-local-override semantic-get-local-variables emacs-lisp-mode | |
665 | (&optional point) | |
666 | "Return a list of local variables for POINT. | |
667 | Scan backwards from point at each successive function. For all occurances | |
668 | of `let' or `let*', grab those variable names." | |
669 | (let* ((vars nil) | |
670 | (fn nil)) | |
671 | (save-excursion | |
672 | (while (setq fn (car (semantic-ctxt-current-function-emacs-lisp-mode | |
673 | (point) (list t)))) | |
674 | (cond | |
675 | ((eq fn t) | |
676 | nil) | |
677 | ((member fn '("let" "let*" "with-slots")) | |
678 | ;; Snarf variables | |
679 | (up-list -1) | |
680 | (forward-char 1) | |
681 | (forward-symbol 1) | |
682 | (skip-chars-forward "* \t\n") | |
683 | (let ((varlst (read (buffer-substring-no-properties | |
684 | (point) | |
685 | (save-excursion | |
686 | (forward-sexp 1) | |
687 | (point)))))) | |
688 | (while varlst | |
689 | (let* ((oneelt (car varlst)) | |
690 | (name (if (symbolp oneelt) | |
691 | oneelt | |
692 | (car oneelt)))) | |
693 | (setq vars (cons (semantic-tag-new-variable | |
694 | (symbol-name name) | |
695 | nil nil) | |
696 | vars))) | |
697 | (setq varlst (cdr varlst))) | |
698 | )) | |
699 | ((string= fn "lambda") | |
700 | ;; Snart args... | |
701 | (up-list -1) | |
702 | (forward-char 1) | |
703 | (forward-word 1) | |
704 | (skip-chars-forward "* \t\n") | |
705 | (let ((arglst (read (buffer-substring-no-properties | |
706 | (point) | |
707 | (save-excursion | |
708 | (forward-sexp 1) | |
709 | (point)))))) | |
710 | (while arglst | |
711 | (let* ((name (car arglst))) | |
712 | (when (/= ?& (aref (symbol-name name) 0)) | |
713 | (setq vars (cons (semantic-tag-new-variable | |
714 | (symbol-name name) | |
715 | nil nil) | |
716 | vars)))) | |
717 | (setq arglst (cdr arglst))) | |
718 | )) | |
719 | ) | |
720 | (up-list -1))) | |
721 | (nreverse vars))) | |
722 | ||
723 | (define-mode-local-override semantic-end-of-command emacs-lisp-mode | |
724 | () | |
725 | "Move cursor to the end of the current command. | |
726 | In emacs lisp this is easilly defined by parenthisis bounding." | |
727 | (condition-case nil | |
728 | (up-list 1) | |
729 | (error nil))) | |
730 | ||
731 | (define-mode-local-override semantic-beginning-of-command emacs-lisp-mode | |
732 | () | |
733 | "Move cursor to the beginning of the current command. | |
734 | In emacs lisp this is easilly defined by parenthisis bounding." | |
735 | (condition-case nil | |
736 | (progn | |
737 | (up-list -1) | |
738 | (forward-char 1)) | |
739 | (error nil))) | |
740 | ||
741 | (define-mode-local-override semantic-ctxt-current-symbol emacs-lisp-mode | |
742 | (&optional point) | |
743 | "List the symbol under point." | |
744 | (save-excursion | |
745 | (if point (goto-char point)) | |
746 | (require 'thingatpt) | |
747 | (let ((sym (thing-at-point 'symbol))) | |
748 | (if sym (list sym))) | |
749 | )) | |
750 | ||
751 | ||
752 | (define-mode-local-override semantic-ctxt-current-assignment emacs-lisp-mode | |
753 | (&optional point) | |
754 | "What is the variable being assigned into at POINT?" | |
755 | (save-excursion | |
756 | (if point (goto-char point)) | |
757 | (let ((fn (semantic-ctxt-current-function point)) | |
758 | (point (point))) | |
759 | ;; We should never get lists from here. | |
760 | (if fn (setq fn (car fn))) | |
761 | (cond | |
762 | ;; SETQ | |
763 | ((and fn (or (string= fn "setq") (string= fn "set"))) | |
764 | (save-excursion | |
765 | (condition-case nil | |
766 | (let ((count 0) | |
767 | (lastodd nil) | |
768 | (start nil)) | |
769 | (up-list -1) | |
770 | (down-list 1) | |
771 | (forward-sexp 1) | |
772 | ;; Skip over sexp until we pass point. | |
773 | (while (< (point) point) | |
774 | (setq count (1+ count)) | |
775 | (forward-comment 1) | |
776 | (setq start (point)) | |
777 | (forward-sexp 1) | |
778 | (if (= (% count 2) 1) | |
779 | (setq lastodd | |
780 | (buffer-substring-no-properties start (point)))) | |
781 | ) | |
782 | (if lastodd (list lastodd)) | |
783 | ) | |
784 | (error nil)))) | |
785 | ;; This obscure thing finds let statements. | |
786 | ((condition-case nil | |
787 | (and | |
788 | (save-excursion | |
789 | (up-list -2) | |
790 | (looking-at "((")) | |
791 | (save-excursion | |
792 | (up-list -3) | |
793 | (looking-at "(let"))) | |
794 | (error nil)) | |
795 | (save-excursion | |
796 | (semantic-beginning-of-command) | |
797 | ;; Use func finding code, since it is the same format. | |
798 | (semantic-ctxt-current-symbol))) | |
799 | ;; | |
800 | ;; DEFAULT- nothing | |
801 | (t nil)) | |
802 | ))) | |
803 | ||
804 | (define-mode-local-override semantic-ctxt-current-argument emacs-lisp-mode | |
805 | (&optional point) | |
806 | "Return the index into the argument the cursor is in, or nil." | |
807 | (save-excursion | |
808 | (if point (goto-char point)) | |
809 | (if (looking-at "\\<\\w") | |
810 | (forward-char 1)) | |
811 | (let ((count 0)) | |
812 | (while (condition-case nil | |
813 | (progn | |
814 | (forward-sexp -1) | |
815 | t) | |
816 | (error nil)) | |
817 | (setq count (1+ count))) | |
818 | (cond ((= count 0) | |
819 | 0) | |
820 | (t (1- count)))) | |
821 | )) | |
822 | ||
823 | (define-mode-local-override semantic-ctxt-current-class-list emacs-lisp-mode | |
824 | (&optional point) | |
825 | "Return a list of tag classes allowed at POINT. | |
826 | Emacs Lisp knows much more about the class of the tag needed to perform | |
827 | completion than some langauges. We distincly know if we are to be | |
828 | a function name, variable name, or any type of symbol. We could identify | |
829 | fields and such to, but that is for some other day." | |
830 | (save-excursion | |
831 | (if point (goto-char point)) | |
832 | (setq point (point)) | |
833 | (condition-case nil | |
834 | (let ((count 0)) | |
835 | (up-list -1) | |
836 | (forward-char 1) | |
837 | (while (< (point) point) | |
838 | (setq count (1+ count)) | |
839 | (forward-sexp 1)) | |
840 | (if (= count 1) | |
841 | '(function) | |
842 | '(variable)) | |
843 | ) | |
844 | (error '(variable))) | |
845 | )) | |
846 | ||
847 | ;;; Formatting | |
848 | ;; | |
849 | (define-mode-local-override semantic-format-tag-abbreviate emacs-lisp-mode | |
850 | (tag &optional parent color) | |
851 | "Return an abbreviated string describing tag." | |
852 | (let ((class (semantic-tag-class tag)) | |
853 | (name (semantic-format-tag-name tag parent color)) | |
854 | ) | |
855 | (cond | |
856 | ((eq class 'function) | |
857 | (concat "(" name ")")) | |
858 | (t | |
859 | (semantic-format-tag-abbreviate-default tag parent color))))) | |
860 | ||
861 | (define-mode-local-override semantic-format-tag-prototype emacs-lisp-mode | |
862 | (tag &optional parent color) | |
863 | "Return a prototype string describing tag. | |
864 | In Emacs Lisp, a prototype for something may start (autoload ...). | |
865 | This is certainly not expected if this is used to display a summary. | |
866 | Make up something else. When we go to write something that needs | |
867 | a real Emacs Lisp protype, we can fix it then." | |
868 | (let ((class (semantic-tag-class tag)) | |
869 | (name (semantic-format-tag-name tag parent color)) | |
870 | ) | |
871 | (cond | |
872 | ((eq class 'function) | |
873 | (let* ((args (semantic-tag-function-arguments tag)) | |
874 | (argstr (semantic--format-tag-arguments args | |
875 | #'identity | |
876 | color))) | |
877 | (concat "(" name (if args " " "") | |
878 | argstr | |
879 | ")"))) | |
880 | (t | |
881 | (semantic-format-tag-prototype-default tag parent color))))) | |
882 | ||
883 | (define-mode-local-override semantic-format-tag-concise-prototype emacs-lisp-mode | |
884 | (tag &optional parent color) | |
885 | "Return a concise prototype string describing tag. | |
886 | See `semantic-format-tag-prototype' for Emacs Lisp for more details." | |
887 | (semantic-format-tag-prototype tag parent color)) | |
888 | ||
889 | (define-mode-local-override semantic-format-tag-uml-prototype emacs-lisp-mode | |
890 | (tag &optional parent color) | |
891 | "Return a uml prototype string describing tag. | |
892 | See `semantic-format-tag-prototype' for Emacs Lisp for more details." | |
893 | (semantic-format-tag-prototype tag parent color)) | |
894 | ||
895 | ;;; IA Commands | |
896 | ;; | |
897 | (define-mode-local-override semantic-ia-insert-tag | |
898 | emacs-lisp-mode (tag) | |
899 | "Insert TAG into the current buffer based on completion." | |
900 | ;; This function by David <de_bb@...> is a tweaked version of the original. | |
901 | (insert (semantic-tag-name tag)) | |
902 | (let ((tt (semantic-tag-class tag)) | |
903 | (args (semantic-tag-function-arguments tag))) | |
904 | (cond ((eq tt 'function) | |
905 | (if args | |
906 | (insert " ") | |
907 | (insert ")"))) | |
908 | (t nil)))) | |
909 | ||
910 | ;;; Lexical features and setup | |
911 | ;; | |
912 | (defvar-mode-local emacs-lisp-mode semantic-lex-analyzer | |
913 | 'semantic-emacs-lisp-lexer) | |
914 | ||
915 | (defvar-mode-local emacs-lisp-mode semantic--parse-table | |
916 | semantic--elisp-parse-table) | |
917 | ||
918 | (defvar-mode-local emacs-lisp-mode semantic-function-argument-separator | |
919 | " ") | |
920 | ||
921 | (defvar-mode-local emacs-lisp-mode semantic-function-argument-separation-character | |
922 | " ") | |
923 | ||
924 | (defvar-mode-local emacs-lisp-mode semantic-symbol->name-assoc-list | |
925 | '( | |
926 | (type . "Types") | |
927 | (variable . "Variables") | |
928 | (function . "Defuns") | |
929 | (include . "Requires") | |
930 | (package . "Provides") | |
931 | )) | |
932 | ||
933 | (defvar-mode-local emacs-lisp-mode imenu-create-index-function | |
934 | 'semantic-create-imenu-index) | |
935 | ||
936 | (defvar-mode-local emacs-lisp-mode semantic-stickyfunc-sticky-classes | |
937 | '(function type variable) | |
938 | "Add variables. | |
939 | ELisp variables can be pretty long, so track this one too.") | |
940 | ||
941 | (define-child-mode lisp-mode emacs-lisp-mode | |
942 | "Make `lisp-mode' inherits mode local behavior from `emacs-lisp-mode'.") | |
943 | ||
944 | (defun semantic-default-elisp-setup () | |
945 | "Setup hook function for Emacs Lisp files and Semantic." | |
946 | ) | |
947 | ||
948 | (add-hook 'emacs-lisp-mode-hook 'semantic-default-elisp-setup) | |
949 | ||
950 | ;;; LISP MODE | |
951 | ;; | |
952 | ;; @TODO: Lisp supports syntaxes that Emacs Lisp does not. | |
953 | ;; Write a Lisp only parser someday. | |
954 | ;; | |
955 | ;; See this syntax: | |
956 | ;; (defun foo () /#A) | |
957 | ;; | |
958 | (add-hook 'lisp-mode-hook 'semantic-default-elisp-setup) | |
959 | ||
960 | (eval-after-load "semanticdb" | |
961 | '(require 'semanticdb-el) | |
962 | ) | |
963 | ||
964 | (provide 'semantic/bovine/el) | |
965 | ||
966 | ;;; semantic/bovine/el.el ends here |