code.delx.au - gnu-emacs/blob - lisp/cedet/semantic/bovine/el.el

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