CVS update by michaels packages/xemacs-packages/semantic/bovine,
semantic-el.el ...
xemacs-cvs at xemacs.org
xemacs-cvs at xemacs.org
Mon Dec 3 02:05:00 EST 2007
User: michaels
Date: 07/12/03 08:05:00
Modified: packages/xemacs-packages/semantic/bovine semantic-c.el
semantic-el.el semantic-make.el semantic-scm.el
Added: packages/xemacs-packages/semantic/bovine
semantic-c.el.upstream semantic-el.el.upstream
semantic-make.el.upstream semantic-scm.el.upstream
Log:
2007-12-03 Mike Sperber <mike at xemacs.org>
* bovine/semantic-scm.el:
* bovine/semantic-make.el:
* bovine/semantic-c.el:
* bovine/semantic-el.el: Don't autoload the hook setup---insist on
loading explicitly.
Revision Changes Path
1.44 +8 -0 XEmacs/packages/xemacs-packages/semantic/ChangeLog
Index: ChangeLog
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/semantic/ChangeLog,v
retrieving revision 1.43
retrieving revision 1.44
diff -u -p -r1.43 -r1.44
--- ChangeLog 2007/12/02 12:56:39 1.43
+++ ChangeLog 2007/12/03 07:04:51 1.44
@@ -1,3 +1,11 @@
+2007-12-03 Mike Sperber <mike at xemacs.org>
+
+ * bovine/semantic-scm.el:
+ * bovine/semantic-make.el:
+ * bovine/semantic-c.el:
+ * bovine/semantic-el.el: Don't autoload the hook setup---insist on
+ loading explicitly.
+
2007-12-02 Mike Sperber <mike at xemacs.org>
* wisent/wisent-comp.el (wisent-BITS-PER-WORD): Max out
1.2 +3 -3 XEmacs/packages/xemacs-packages/semantic/bovine/semantic-c.el
Index: semantic-c.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/semantic/bovine/semantic-c.el,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -p -r1.1 -r1.2
--- semantic-c.el 2007/11/26 15:11:55 1.1
+++ semantic-c.el 2007/12/03 07:04:56 1.2
@@ -3,7 +3,7 @@
;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 Eric M. Ludlam
;; Author: Eric M. Ludlam <zappo at gnu.org>
-;; X-RCS: $Id: semantic-c.el,v 1.1 2007/11/26 15:11:55 michaels Exp $
+;; X-RCS: $Id: semantic-c.el,v 1.2 2007/12/03 07:04:56 michaels Exp $
;; This file is not part of GNU Emacs.
@@ -785,10 +785,10 @@ DO NOT return the list of tags encompass
(semantic-lex-make-spp-table
semantic-lex-c-preprocessor-symbol-map)))
-;;;###autoload
+; ;;;###autoload
(add-hook 'c-mode-hook 'semantic-default-c-setup)
;;;###autoload
-(add-hook 'c++-mode-hook 'semantic-default-c-setup)
+; (add-hook 'c++-mode-hook 'semantic-default-c-setup)
(define-child-mode c++-mode c-mode
"`c++-mode' uses the same parser as `c-mode'.")
1.2 +4 -4 XEmacs/packages/xemacs-packages/semantic/bovine/semantic-el.el
Index: semantic-el.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/semantic/bovine/semantic-el.el,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -p -r1.1 -r1.2
--- semantic-el.el 2007/11/26 15:11:55 1.1
+++ semantic-el.el 2007/12/03 07:04:56 1.2
@@ -3,7 +3,7 @@
;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007 Eric M. Ludlam
;; Author: Eric M. Ludlam <zappo at gnu.org>
-;; X-RCS: $Id: semantic-el.el,v 1.1 2007/11/26 15:11:55 michaels Exp $
+;; X-RCS: $Id: semantic-el.el,v 1.2 2007/12/03 07:04:56 michaels Exp $
;; This file is not part of GNU Emacs.
@@ -816,7 +816,7 @@ See `semantic-format-tag-prototype' for
"Setup hook function for Emacs Lisp files and Semantic."
)
-;;;###autoload
+; ;;;###autoload
(add-hook 'emacs-lisp-mode-hook 'semantic-default-elisp-setup)
;;; LISP MODE
@@ -827,10 +827,10 @@ See `semantic-format-tag-prototype' for
;; See this syntax:
;; (defun foo () /#A)
;;
-;;;###autoload
+; ;;;###autoload
(add-hook 'lisp-mode-hook 'semantic-default-elisp-setup)
-;;;###autoload
+; ;;;###autoload
(eval-after-load "semanticdb"
'(require 'semanticdb-el)
)
1.2 +2 -2 XEmacs/packages/xemacs-packages/semantic/bovine/semantic-make.el
Index: semantic-make.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/semantic/bovine/semantic-make.el,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -p -r1.1 -r1.2
--- semantic-make.el 2007/11/26 15:11:57 1.1
+++ semantic-make.el 2007/12/03 07:04:57 1.2
@@ -3,7 +3,7 @@
;; Copyright (C) 2000, 2001, 2002, 2003, 2004 Eric M. Ludlam
;; Author: Eric M. Ludlam <zappo at gnu.org>
-;; X-RCS: $Id: semantic-make.el,v 1.1 2007/11/26 15:11:57 michaels Exp $
+;; X-RCS: $Id: semantic-make.el,v 1.2 2007/12/03 07:04:57 michaels Exp $
;; This file is not part of GNU Emacs.
@@ -203,7 +203,7 @@ Uses default implementation, and also ge
(setq semantic-lex-analyzer #'semantic-make-lexer)
)
-;;;###autoload
+; ;;;###autoload
(add-hook 'makefile-mode-hook 'semantic-default-make-setup)
(provide 'semantic-make)
1.2 +2 -2 XEmacs/packages/xemacs-packages/semantic/bovine/semantic-scm.el
Index: semantic-scm.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/semantic/bovine/semantic-scm.el,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -p -r1.1 -r1.2
--- semantic-scm.el 2007/11/26 15:11:58 1.1
+++ semantic-scm.el 2007/12/03 07:04:57 1.2
@@ -3,7 +3,7 @@
;;; Copyright (C) 2001, 2002, 2003, 2004 Eric M. Ludlam
;; Author: Eric M. Ludlam <zappo at gnu.org>
-;; X-RCS: $Id: semantic-scm.el,v 1.1 2007/11/26 15:11:58 michaels Exp $
+;; X-RCS: $Id: semantic-scm.el,v 1.2 2007/12/03 07:04:57 michaels Exp $
;; 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
@@ -104,7 +104,7 @@ syntax as specified by the syntax table.
(setq semantic-lex-analyzer #'semantic-scheme-lexer)
)
-;;;###autoload
+; ;;;###autoload
(add-hook 'scheme-mode-hook 'semantic-default-scheme-setup)
(provide 'semantic-scm)
1.1 XEmacs/packages/xemacs-packages/semantic/bovine/semantic-c.el.upstream
Index: semantic-c.el.upstream
===================================================================
;;; semantic-c.el --- Semantic details for C
;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 Eric M. Ludlam
;; Author: Eric M. Ludlam <zappo at gnu.org>
;; X-RCS: $Id: semantic-c.el.upstream,v 1.1 2007/12/03 07:04:56 michaels Exp $
;; This file is not part of GNU Emacs.
;; This 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 software 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 GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;
;;; History:
;;
(require 'semantic)
(require 'semantic-lex-spp)
(require 'semantic-c-by)
(require 'backquote)
(eval-when-compile
(require 'semantic-ctxt)
(require 'semantic-imenu)
(require 'semantic-tag-ls)
(require 'document)
(require 'senator)
(require 'cc-mode))
;;; Compatibility
;;
(if (fboundp 'c-end-of-macro)
(eval-and-compile
(defalias 'semantic-c-end-of-macro 'c-end-of-macro))
;; From cc-mode 5.30
(defun semantic-c-end-of-macro ()
"Go to the end of a preprocessor directive.
More accurately, move point to the end of the closest following line
that doesn't end with a line continuation backslash.
This function does not do any hidden buffer changes."
(while (progn
(end-of-line)
(when (and (eq (char-before) ?\\)
(not (eobp)))
(forward-char)
t))))
)
;;-------
;;; Lexical analysis
(defcustom semantic-lex-c-preprocessor-symbol-map nil
"Table of C Preprocessor keywords used by the Semantic C lexer."
:group 'c
:type '(repeat (cons (string :tag "Keyword")
(string :tag "Replacement")))
)
;;; Code:
(define-lex-spp-macro-declaration-analyzer semantic-lex-cpp-define
"A #define of a symbol with some value.
Record the symbol in the semantic preprocessor.
Return the the defined symbol as a special spp lex token."
"^\\s-*#define\\s-+\\(\\(\\sw\\|\\s_\\)+\\)" 1
(goto-char (match-end 0))
(skip-chars-forward " \t")
(if (eolp)
nil
(prog1
(buffer-substring-no-properties (point)
(progn
;; NOTE: THIS SHOULD BE
;; END OF MACRO!!!
(forward-word 1)
(point)))
;; Move the lexical end after the value.
(semantic-c-end-of-macro)
;; Magical spp variable for end point.
(setq semantic-lex-end-point (point))
)))
(define-lex-spp-macro-undeclaration-analyzer semantic-lex-cpp-undef
"A #undef of a symbol.
Remove the symbol from the semantic preprocessor.
Return the the defined symbol as a special spp lex token."
"^\\s-*#undef\\s-+\\(\\(\\sw\\|\\s_\\)+\\)" 1)
(defun semantic-c-skip-conditional-section ()
"Skip one section of a conditional.
Moves forward to a matching #elif, #else, or #endif.
Movers completely over balanced #if blocks."
(let ((done nil))
;; (if (looking-at "^\\s-*#if")
;; (semantic-lex-spp-push-if (point))
(end-of-line)
(while (and (not done)
(re-search-forward "^\\s-*#\\(if\\(n?def\\)?\\|el\\(if\\|se\\)\\|endif\\)\\>" nil t))
(goto-char (match-beginning 0))
(cond
((looking-at "^\\s-*#if")
;; We found a nested if. Skip it.
(c-forward-conditional 1))
((looking-at "^\\s-*#\\(endif\\|else\\)\\>")
;; We are at the end. Pop our state.
;; (semantic-lex-spp-pop-if)
;; Note: We include ELSE and ENDIF the same. If skip some previous
;; section, then we should do the else by default, making it much
;; like the endif.
(end-of-line)
(forward-char 1)
(setq done t))
(t
;; We found an elif. Stop here.
(setq done t))))))
(define-lex-regex-analyzer semantic-lex-c-if
"Code blocks wrapped up in #if, or #ifdef.
Uses known macro tables in SPP to determine what block to skip."
"^\\s-*#\\(if\\|ifndef\\|ifdef\\|elif\\)\\s-+\\(!?defined(\\|\\)\\(\\(\\sw\\|\\s_\\)+\\))?\\s-*$"
(let* ((sym (buffer-substring-no-properties
(match-beginning 3) (match-end 3)))
(defstr (buffer-substring-no-properties
(match-beginning 2) (match-end 2)))
(defined (string= defstr "defined("))
(notdefined (string= defstr "!defined("))
(ift (buffer-substring-no-properties
(match-beginning 1) (match-end 1)))
(ifdef (or (string= ift "ifdef")
(and (string= ift "if") defined)
(and (string= ift "elif") defined)
))
(ifndef (or (string= ift "ifndef")
(and (string= ift "if") notdefined)
(and (string= ift "elif") notdefined)
))
)
(if (or (and (or (string= ift "if") (string= ift "elif"))
(string= sym "0"))
(and ifdef (not (semantic-lex-spp-symbol-p sym)))
(and ifndef (semantic-lex-spp-symbol-p sym)))
;; The if indecates to skip this preprocessor section
(let ((pt nil))
;; (message "%s %s yes" ift sym)
(beginning-of-line)
(setq pt (point))
;;(c-forward-conditional 1)
;; This skips only a section of a conditional. Once that section
;; is opened, encountering any new #else or related conditional
;; should be skipped.
(semantic-c-skip-conditional-section)
(setq semantic-lex-end-point (point))
(semantic-push-parser-warning (format "Skip #%s %s" ift sym)
pt (point))
;; (semantic-lex-push-token
;; (semantic-lex-token 'c-preprocessor-skip pt (point)))
nil)
;; Else, don't ignore it, but do handle the internals.
;;(message "%s %s no" ift sym)
(end-of-line)
(setq semantic-lex-end-point (point))
nil)))
(define-lex-regex-analyzer semantic-lex-c-macro-else
"Ignore an #else block.
We won't see the #else due to the macro skip section block
unless we are actively parsing an open #if statement. In that
case, we must skip it since it is the ELSE part."
"^#\\(else\\)"
(let ((pt (point)))
(semantic-c-skip-conditional-section)
(setq semantic-lex-end-point (point))
(semantic-push-parser-warning "Skip #else" pt (point))
;; (semantic-lex-push-token
;; (semantic-lex-token 'c-preprocessor-skip pt (point)))
nil))
(define-lex-regex-analyzer semantic-lex-c-macrobits
"Ignore various forms of #if/#else/#endif conditionals."
"^#\\(if\\(def\\)?\\|endif\\)"
(semantic-c-end-of-macro)
(setq semantic-lex-end-point (point))
nil)
(define-lex-analyzer semantic-lex-c-include-system
"Identify system include strings, and return special tokens."
(and (looking-at "<[^\n>]+>")
(save-excursion
(beginning-of-line)
(looking-at "\\s-*#\\s-*include\\s-+<"))
(= (match-end 0) (1+ (point))))
;; We found a system include.
(let ((start (point)))
;; This should always pass
(re-search-forward ">")
;; We have the whole thing.
(semantic-lex-push-token
(semantic-lex-token 'system-include start (point)))
)
)
(define-lex-regex-analyzer semantic-lex-c-ignore-ending-backslash
"Skip backslash ending a line.
Go to the next line."
"\\\\\\s-*\n"
(setq semantic-lex-end-point (match-end 0)))
(define-lex-regex-analyzer semantic-lex-c-string
"Detect and create a C string token."
"L?\\(\\s\"\\)"
;; Zing to the end of this string.
(semantic-lex-push-token
(semantic-lex-token
'string (point)
(save-excursion
;; Skip L prefix if present.
(goto-char (match-beginning 1))
(semantic-lex-unterminated-syntax-protection 'string
(forward-sexp 1)
(point))
))))
(define-lex semantic-c-lexer
"Lexical Analyzer for C code."
semantic-lex-ignore-whitespace
semantic-lex-ignore-newline
;; C preprocessor features
semantic-lex-cpp-define
semantic-lex-cpp-undef
semantic-lex-c-if
semantic-lex-c-macro-else
semantic-lex-c-macrobits
semantic-lex-c-include-system
semantic-lex-c-ignore-ending-backslash
;; Non-preprocessor features
semantic-lex-number
;; Must detect C strings before symbols because of possible L prefix!
semantic-lex-c-string
semantic-lex-spp-replace-or-symbol-or-keyword
semantic-lex-charquote
semantic-lex-paren-or-list
semantic-lex-close-paren
semantic-lex-ignore-comments
semantic-lex-punctuation
semantic-lex-default-action)
(defun semantic-expand-c-tag (tag)
"Expand TAG into a list of equivalent tags, or nil."
(cond ((eq (semantic-tag-class tag) 'extern)
;; We have hit an exter "C" command with a list after it.
(let* ((mb (semantic-tag-get-attribute tag :members))
(ret mb))
(while mb
(let ((mods (semantic-tag-get-attribute (car mb) :typemodifiers)))
(setq mods (cons "extern" (cons "\"C\"" mods)))
(semantic-tag-put-attribute (car mb) :typemodifiers mods))
(setq mb (cdr mb)))
ret))
((listp (car tag))
(cond ((eq (semantic-tag-class tag) 'variable)
;; The name part comes back in the form of:
;; ( NAME NUMSTARS BITS ARRAY ASSIGN )
(let ((vl nil)
(basety (semantic-tag-type tag))
(ty "")
(mods (semantic-tag-get-attribute tag :typemodifiers))
(suffix "")
(lst (semantic-tag-name tag))
(default nil)
(cur nil))
(while lst
(setq suffix "" ty "")
(setq cur (car lst))
(if (nth 2 cur)
(setq suffix (concat ":" (nth 2 cur))))
(if (= (length basety) 1)
(setq ty (car basety))
(setq ty basety))
(setq default (nth 4 cur))
(setq vl (cons
(semantic-tag-new-variable
(car cur) ;name
ty ;type
(if default
(buffer-substring-no-properties
(car default) (car (cdr default))))
:constant-flag (semantic-tag-variable-constant-p tag)
:suffix suffix
:typemodifiers mods
:dereference (length (nth 3 cur))
:pointer (nth 1 cur)
:documentation (semantic-tag-docstring tag) ;doc
)
vl))
(semantic--tag-copy-properties tag (car vl))
(semantic--tag-set-overlay (car vl)
(semantic-tag-overlay tag))
(setq lst (cdr lst)))
vl))
((eq (semantic-tag-class tag) 'type)
;; We may someday want to add an extra check for a type
;; of type "typedef".
;; Each elt of NAME is ( STARS NAME )
(let ((vl nil)
(names (semantic-tag-name tag)))
(while names
(setq vl (cons (semantic-tag-new-type
(nth 1 (car names)) ; name
"typedef"
(semantic-tag-type-members tag)
;; parent is just tbe name of what
;; is passed down as a tag.
(list
(semantic-tag-name
(semantic-tag-type-superclasses tag)))
:pointer
(let ((stars (car (car (car names)))))
(if (= stars 0) nil stars))
;; This specifies what the typedef
;; is expanded out as. Just the
;; name shows up as a parent of this
;; typedef.
:typedef
(semantic-tag-type-superclasses tag)
:documentation
(semantic-tag-docstring tag))
vl))
(semantic--tag-copy-properties tag (car vl))
(semantic--tag-set-overlay (car vl)
(semantic-tag-overlay tag))
(setq names (cdr names)))
vl))
((and (listp (car tag))
(eq (semantic-tag-class (car tag)) 'variable))
;; Argument lists come in this way. Append all the expansions!
(let ((vl nil))
(while tag
(setq vl (append (semantic-tag-components (car vl))
vl)
tag (cdr tag)))
vl))
(t nil)))
(t nil)))
(defvar-mode-local c-mode semantic-tag-expand-function 'semantic-expand-c-tag
"Function used to expand tags generated in the C bovine parser.")
(defvar semantic-c-classname nil
"At parse time, assign a class or struct name text here.
It is picked up by `semantic-c-reconstitute-token' to determine
if something is a constructor. Value should be:
( TYPENAME . TYPEOFTYPE)
where typename is the name of the type, and typeoftype is \"class\"
or \"struct\".")
(defun semantic-c-reconstitute-token (tokenpart declmods typedecl)
"Reconstitute a token TOKENPART with DECLMODS and TYPEDECL.
This is so we don't have to match the same starting text several times.
Optional argument STAR and REF indicate the number of * and & in the typedef."
(when (and (listp typedecl)
(= 1 (length typedecl))
(stringp (car typedecl)))
(setq typedecl (car typedecl)))
(cond ((eq (nth 1 tokenpart) 'variable)
(semantic-tag-new-variable
(car tokenpart)
(or typedecl "int") ;type
nil ;default value (filled with expand)
:constant-flag (if (member "const" declmods) t nil)
:typemodifiers (delete "const" declmods)
)
)
((eq (nth 1 tokenpart) 'function)
;; We should look at part 4 (the arglist) here, and throw an
;; error of some sort if it contains parser errors so that we
;; don't parser function calls, but that is a little beyond what
;; is available for data here.
(let* ((constructor
(and (or (and semantic-c-classname
(string= (car semantic-c-classname)
(car tokenpart)))
(and (stringp (car (nth 2 tokenpart)))
(string= (car (nth 2 tokenpart)) (car tokenpart)))
)
(not (car (nth 3 tokenpart)))))
(fcnpointer (string-match "^\\*" (car tokenpart)))
(fnname (if fcnpointer
(substring (car tokenpart) 1)
(car tokenpart)))
(operator (if (string-match "[a-zA-Z]" fnname)
nil
t))
)
(if fcnpointer
;; Function pointers are really variables.
(semantic-tag-new-variable
fnname
typedecl
nil
;; It is a function pointer
:functionpointer-flag t
)
;; The function
(semantic-tag-new-function
fnname
(or typedecl ;type
(cond ((car (nth 3 tokenpart) )
"void") ; Destructors have no return?
(constructor
;; Constructors return an object.
(semantic-tag-new-type
;; name
(or (car semantic-c-classname)
(car (nth 2 tokenpart)))
;; type
(or (cdr semantic-c-classname)
"class")
;; members
nil
;; parents
nil
))
(t "int")))
(nth 4 tokenpart) ;arglist
:constant-flag (if (member "const" declmods) t nil)
:typemodifiers (delete "const" declmods)
:parent (car (nth 2 tokenpart))
:destructor-flag (if (car (nth 3 tokenpart) ) t)
:constructor-flag (if constructor t)
:pointer (nth 7 tokenpart)
:operator-flag operator
;; Even though it is "throw" in C++, we use
;; `throws' as a common name for things that toss
;; exceptions about.
:throws (nth 5 tokenpart)
;; Reemtrant is a C++ thingy. Add it here
:reentrant-flag (if (member "reentrant" (nth 6 tokenpart)) t)
;; A function post-const is funky. Try stuff
:methodconst-flag (if (member "const" (nth 6 tokenpart)) t)
;; prototypes are functions w/ no body
:prototype-flag (if (nth 8 tokenpart) t)
;; Pure virtual
:pure-virtual-flag (if (eq (nth 8 tokenpart) :pure-virtual-flag) t)
)))
)
))
(defun semantic-c-reconstitute-template (tag specifier)
"Reconstitute the token TAG with the template SPECIFIER."
(semantic-tag-put-attribute tag :template (or specifier ""))
tag)
;;; Override methods & Variables
;;
(defvar-mode-local c-mode semantic-dependency-system-include-path
'("/usr/include" "/usr/dt/include" "/usr/X11R6/include")
"System path to search for include files.")
(defcustom semantic-default-c-path nil
"Default set of include paths for C code.
Used by `semantic-dep' to define an include path.
NOTE: In process of obsoleting this."
:group 'c
:group 'semantic
:type '(repeat (string :tag "Path")))
(defvar-mode-local c-mode semantic-dependency-include-path
semantic-default-c-path
"System path to search for include files.")
(define-mode-local-override semantic-format-tag-name
c-mode (tag &optional parent color)
"Convert TAG to a string that is the print name for TAG.
Optional PARENT and COLOR are ignored."
(let ((name (semantic-format-tag-name-default tag parent color))
(fnptr (semantic-tag-get-attribute tag :functionpointer-flag))
)
(if (not fnptr)
name
(concat "(*" name ")"))
))
(define-mode-local-override semantic-format-tag-canonical-name
c-mode (tag &optional parent color)
"Create a cannonical name for TAG.
PARENT specifies a parent class.
COLOR indicates that the text should be type colorized.
Enhances the base class to search for the entire parent
tree to make the name accurate."
(semantic-format-tag-canonical-name-default tag parent color)
)
(define-mode-local-override semantic-format-tag-type c-mode (tag color)
"Convert the data type of TAG to a string usable in tag formatting.
Adds pointer and reference symbols to the default.
Argument COLOR adds color to the text."
(let* ((type (semantic-tag-type tag))
(defaulttype nil)
(point (semantic-tag-get-attribute tag :pointer))
(ref (semantic-tag-get-attribute tag :reference))
)
(if (semantic-tag-p type)
(let ((typetype (semantic-tag-type type))
(typename (semantic-tag-name type)))
;; Create the string that expresses the type
(if (string= typetype "class")
(setq defaulttype typename)
(setq defaulttype (concat typetype " " typename))))
(setq defaulttype (semantic-format-tag-type-default tag color)))
;; Colorize
(when color
(setq defaulttype (semantic--format-colorize-text defaulttype 'type)))
;; Add refs, ptrs, etc
(if ref (setq ref "&"))
(if point (setq point (make-string point ?*)) "")
(when type
(concat defaulttype ref point))
))
(define-mode-local-override semantic-tag-protection
c-mode (token &optional parent)
"Return the protection of TOKEN in PARENT.
Override function for `semantic-tag-protection'."
(let ((mods (semantic-tag-modifiers token))
(prot nil))
;; Check the modifiers for protection if we are not a child
;; of some class type.
(when (or (not parent) (not (eq (semantic-tag-class parent) 'type)))
(while (and (not prot) mods)
(if (stringp (car mods))
(let ((s (car mods)))
;; A few silly defaults to get things started.
(cond ((or (string= s "extern")
(string= s "export"))
'public)
((string= s "static")
'private))))
(setq mods (cdr mods))))
;; If we have a typed parent, look for :public style labels.
(when (and parent (eq (semantic-tag-class parent) 'type))
(let ((pp (semantic-tag-type-members parent)))
(while (and pp (not (semantic-equivalent-tag-p (car pp) token)))
(when (eq (semantic-tag-class (car pp)) 'label)
(setq prot
(cond ((string= (semantic-tag-name (car pp)) "public")
'public)
((string= (semantic-tag-name (car pp)) "private")
'private)
((string= (semantic-tag-name (car pp)) "protected")
'protected)))
)
(setq pp (cdr pp)))))
(when (and (not prot) (eq (semantic-tag-class parent) 'type))
(setq prot
(cond ((string= (semantic-tag-type parent) "class") 'private)
((string= (semantic-tag-type parent) "struct") 'public)
(t 'unknown))))
(or prot
(if (and parent (semantic-tag-of-class-p parent 'type))
'public
nil))))
(define-mode-local-override semantic-tag-components c-mode (tag)
"Return components for TAG."
(if (and (eq (semantic-tag-class tag) 'type)
(string= (semantic-tag-type tag) "typedef"))
;; A typedef can contain a parent who has positional children,
;; but that parent will not have a position. Do this funny hack
;; to make sure we can apply overlays properly.
(semantic-tag-components (semantic-tag-type-superclasses tag))
(semantic-tag-components-default tag)))
(defun semantic-c-tag-template (tag)
"Return the template specification for TAG, or nil."
(semantic-tag-get-attribute tag :template))
(defun semantic-c-tag-template-specifier (tag)
"Return the template specifier specification for TAG, or nil."
(semantic-tag-get-attribute tag :template-specifier))
(defun semantic-c-template-string-body (templatespec)
"Convert TEMPLATESPEC into a string.
This might be a string, or a list of tokens."
(cond ((stringp templatespec)
templatespec)
((semantic-tag-p templatespec)
(semantic-format-tag-abbreviate templatespec))
((listp templatespec)
(mapconcat 'semantic-format-tag-abbreviate templatespec ", "))))
(defun semantic-c-template-string (token &optional parent color)
"Return a string representing the TEMPLATE attribute of TOKEN.
This string is prefixed with a space, or is the empty string.
Argument PARENT specifies a parent type.
Argument COLOR specifies that the string should be colorized."
(let ((t2 (semantic-c-tag-template-specifier token))
(t1 (semantic-c-tag-template token))
(pt1 (if parent (semantic-c-tag-template parent)))
(pt2 (if parent (semantic-c-tag-template-specifier parent)))
)
(cond (t2 ;; we have a template with specifier
(concat " <"
;; Fill in the parts here
(semantic-c-template-string-body t2)
">"))
(t1 ;; we have a template without specifier
" <>")
(t
""))))
(define-mode-local-override semantic-format-tag-concise-prototype
c-mode (token &optional parent color)
"Return an abbreviated string describing TOKEN for C and C++.
Optional PARENT and COLOR as specified with
`semantic-format-tag-abbreviate-default'."
;; If we have special template things, append.
(concat (semantic-format-tag-concise-prototype-default token parent color)
(semantic-c-template-string token parent color)))
(define-mode-local-override semantic-format-tag-uml-prototype
c-mode (token &optional parent color)
"Return an uml string describing TOKEN for C and C++.
Optional PARENT and COLOR as specified with
`semantic-abbreviate-tag-default'."
;; If we have special template things, append.
(concat (semantic-format-tag-uml-prototype-default token parent color)
(semantic-c-template-string token parent color)))
(define-mode-local-override semantic-tag-abstract-p
c-mode (tag &optional parent)
"Return non-nil if TAG is considered abstract.
PARENT is tag's parent.
In C, a method is abstract if it is `virtual', which is already
handled. A class is abstract iff it's destructor is virtual."
(cond
((eq (semantic-tag-class tag) 'type)
(or (semantic-brute-find-tag-by-attribute :pure-virtual-flag
(semantic-tag-components tag)
)
(let* ((ds (semantic-brute-find-tag-by-attribute
:destructor-flag
(semantic-tag-components tag)
))
(cs (semantic-brute-find-tag-by-attribute
:constructor-flag
(semantic-tag-components tag)
)))
(and ds (member "virtual" (semantic-tag-modifiers (car ds)))
cs (eq 'protected (semantic-tag-protection (car cs) tag))
)
)))
((eq (semantic-tag-class tag) 'function)
(or (semantic-tag-get-attribute tag :pure-virtual-flag)
(member "virtual" (semantic-tag-modifiers tag))))
(t (semantic-tag-abstract-p-default tag parent))))
(define-mode-local-override semantic-analyze-dereference-metatype
c-mode (type scope)
"Dereference TYPE as described in `semantic-analyze-dereference-metatype'.
If TYPE is a typedef, get TYPE's type by name or tag, and return."
(if (and (eq (semantic-tag-class type) 'type)
(string= (semantic-tag-type type) "typedef"))
(semantic-tag-get-attribute type :typedef)
type))
(define-mode-local-override semantic-analyze-type-constants c-mode (type)
"When TYPE is a tag for an enum, return it's parts.
These are constants which are of type TYPE."
(if (and (eq (semantic-tag-class type) 'type)
(string= (semantic-tag-type type) "enum"))
(semantic-tag-type-members type)))
(define-mode-local-override semantic-analyze-split-name c-mode (name)
"Split up tag names on colon (:) boundaries."
(let ((ans (split-string name ":")))
(if (= (length ans) 1)
name
(delete "" ans))))
(define-mode-local-override semantic-ctxt-scoped-types c-mode (&optional point)
"Return a list of tags of CLASS type based on POINT.
DO NOT return the list of tags encompassing point."
(when point (goto-char (point)))
(let ((tagreturn nil)
(tmp nil))
;; In C++, we want to find all the namespaces declared
;; locally and add them to the list.
(setq tmp (semantic-find-tags-by-class 'type (current-buffer)))
(setq tmp (semantic-find-tags-by-type "namespace" tmp))
(setq tagreturn tmp)
;; We should also find all "using" type statements and
;; accept those entities in as well.
;; Return the stuff
tagreturn
))
(defvar-mode-local c-mode semantic-orphaned-member-metaparent-type "struct"
"When lost memberes are found in the class hierarchy generator, use a struct.")
(defvar-mode-local c-mode semantic-symbol->name-assoc-list
'((type . "Types")
(variable . "Variables")
(function . "Functions")
(include . "Includes")
)
"List of tag classes, and strings to describe them.")
(defvar-mode-local c-mode semantic-symbol->name-assoc-list-for-type-parts
'((type . "Types")
(variable . "Attributes")
(function . "Methods")
(label . "Labels")
)
"List of tag classes in a datatype decl, and strings to describe them.")
(defvar-mode-local c-mode imenu-create-index-function 'semantic-create-imenu-index
"Imenu index function for C.")
(defvar-mode-local c-mode semantic-type-relation-separator-character
'("." "->")
"Separator characters between something of a give type, and a field.")
(defvar-mode-local c-mode semantic-command-separation-character ";"
"Commen separation character for C")
(defvar-mode-local c-mode document-comment-start "/*"
"Comment start string.")
(defvar-mode-local c-mode document-comment-line-prefix " *"
"Tween line comment decoration character.")
(defvar-mode-local c-mode document-comment-end " */"
"Comment termination string.")
(defvar-mode-local c-mode senator-step-at-tag-classes '(function variable)
"Tag classes where senator will stop at the end.")
;;;###autoload
(defun semantic-default-c-setup ()
"Set up a buffer for semantic parsing of the C language."
(semantic-c-by--install-parser)
(setq semantic-lex-syntax-modifications '((?> ".")
(?< ".")
)
)
(setq semantic-lex-analyzer #'semantic-c-lexer)
(setq semantic-lex-spp-macro-symbol-obarray
(semantic-lex-make-spp-table semantic-lex-c-preprocessor-symbol-map))
(add-hook 'semantic-lex-reset-hooks 'semantic-lex-spp-reset-hook nil t)
)
;;;###autoload
(defun semantic-c-add-preprocessor-symbol (sym replacement)
"Add a preprocessor symbol SYM with a REPLACEMENT value."
(interactive "sSymbol: \nsReplacement: ")
(let ((SA (assoc sym semantic-lex-c-preprocessor-symbol-map)))
(if SA
;; Replace if there is one.
(setcdr SA replacement)
;; Otherwise, append
(setq semantic-lex-c-preprocessor-symbol-map
(cons (cons sym replacement)
semantic-lex-c-preprocessor-symbol-map))))
(setq-mode-local c-mode
semantic-lex-spp-macro-symbol-obarray
(semantic-lex-make-spp-table
semantic-lex-c-preprocessor-symbol-map)))
;;;###autoload
(add-hook 'c-mode-hook 'semantic-default-c-setup)
;;;###autoload
(add-hook 'c++-mode-hook 'semantic-default-c-setup)
(define-child-mode c++-mode c-mode
"`c++-mode' uses the same parser as `c-mode'.")
(provide 'semantic-c)
;;; semantic-c.el ends here
1.1 XEmacs/packages/xemacs-packages/semantic/bovine/semantic-el.el.upstream
Index: semantic-el.el.upstream
===================================================================
;;; semantic-el.el --- Semantic details for Emacs Lisp
;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007 Eric M. Ludlam
;; Author: Eric M. Ludlam <zappo at gnu.org>
;; X-RCS: $Id: semantic-el.el.upstream,v 1.1 2007/12/03 07:04:57 michaels Exp $
;; This file is not part of GNU Emacs.
;; Semantic-ex 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 software 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 GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;
;; Use the Semantic Bovinator for Emacs Lisp
(require 'semantic)
(require 'semantic-bovine)
(require 'backquote)
(require 'find-func)
(eval-when-compile
(require 'semantic-imenu)
)
;;; Code:
;;; Lexer
;;
(define-lex semantic-emacs-lisp-lexer
"A simple lexical analyzer for Emacs Lisp.
This lexer ignores comments and whitespace, and will return
syntax as specified by the syntax table."
semantic-lex-ignore-whitespace
semantic-lex-ignore-newline
semantic-lex-number
semantic-lex-symbol-or-keyword
semantic-lex-charquote
semantic-lex-paren-or-list
semantic-lex-close-paren
semantic-lex-string
semantic-lex-ignore-comments
semantic-lex-punctuation
semantic-lex-default-action)
;;; Parser
;;
(defvar semantic--elisp-parse-table
`((bovine-toplevel
(semantic-list
,(lambda (vals start end)
(let ((tag (semantic-elisp-use-read (car vals))))
(cond
((and (listp tag) (semantic-tag-p (car tag)))
;; We got a list of tags back. This list is
;; returned here in the correct order, but this
;; list gets reversed later, putting the correctly ordered
;; items into reverse order later.
(nreverse tag))
((semantic--tag-expanded-p tag)
;; At this point, if `semantic-elisp-use-read' returned an
;; already expanded tag (from definitions parsed inside an
;; eval and compile wrapper), just pass it!
tag)
(t
;; We got the basics of a single tag.
(append tag (list start end))))))))
)
"Top level bovination table for elisp.")
(defun semantic-elisp-desymbolify (arglist)
"Convert symbols to strings for ARGLIST."
(let ((out nil))
(while arglist
(setq out
(cons
(if (symbolp (car arglist))
(symbol-name (car arglist))
(if (and (listp (car arglist))
(symbolp (car (car arglist))))
(symbol-name (car (car arglist)))
(format "%S" (car arglist))))
out)
arglist (cdr arglist)))
(nreverse out)))
(defun semantic-elisp-clos-slot-property-string (slot property)
"For SLOT, a string representing PROPERTY."
(let ((p (member property slot)))
(if (not p)
nil
(setq p (cdr p))
(cond
((stringp (car p))
(car p))
((or (symbolp (car p)) (listp (car p)))
(format "%S" (car p)))
(t nil)))))
(defun semantic-elisp-clos-args-to-semantic (partlist)
"Convert a list of CLOS class slot PARTLIST to `variable' tags."
(let (vars part v)
(while partlist
(setq part (car partlist)
partlist (cdr partlist)
v (semantic-tag-new-variable
(symbol-name (car part))
(semantic-elisp-clos-slot-property-string part :type)
(semantic-elisp-clos-slot-property-string part :initform)
;; Attributes
:protection (semantic-elisp-clos-slot-property-string
part :protection)
:static-flag (equal (semantic-elisp-clos-slot-property-string
part :allocation)
":class")
:documentation (semantic-elisp-clos-slot-property-string
part :documentation))
vars (cons v vars)))
(nreverse vars)))
(defun semantic-elisp-form-to-doc-string (form)
"After reading a form FORM, covert it to a doc string.
For Emacs Lisp, sometimes that string is non-existant.
Sometimes it is a form which is evaluated at compile time, permitting
compound strings."
(cond ((stringp form) form)
((and (listp form) (eq (car form) 'concat)
(stringp (nth 1 form)))
(nth 1 form))
(t nil)))
(defvar semantic-elisp-store-documentation-in-tag nil
"*When non-nil, store documentation strings in the created tags.")
(defun semantic-elisp-do-doc (str)
"Return STR as a documentation string IF they are enabled."
(when semantic-elisp-store-documentation-in-tag
(semantic-elisp-form-to-doc-string str)))
(defmacro semantic-elisp-setup-form-parser (parser &rest symbols)
"Install the function PARSER as the form parser for SYMBOLS.
SYMBOLS is a list of symbols identifying the forms to parse.
PARSER is called on every forms whose first element (car FORM) is
found in SYMBOLS. It is passed the parameters FORM, START, END,
where:
- FORM is an Elisp form read from the current buffer.
- START and END are the beginning and end location of the
corresponding data in the current buffer."
(let ((sym (make-symbol "sym")))
`(dolist (,sym ',symbols)
(put ,sym 'semantic-elisp-form-parser #',parser))))
(put 'semantic-elisp-setup-form-parser 'lisp-indent-function 1)
(defmacro semantic-elisp-reuse-form-parser (symbol &rest symbols)
"Reuse the form parser of SYMBOL for forms identified by SYMBOLS.
See also `semantic-elisp-setup-form-parser'."
(let ((parser (make-symbol "parser"))
(sym (make-symbol "sym")))
`(let ((,parser (get ',symbol 'semantic-elisp-form-parser)))
(or ,parser
(signal 'wrong-type-argument
'(semantic-elisp-form-parser ,symbol)))
(dolist (,sym ',symbols)
(put ,sym 'semantic-elisp-form-parser ,parser)))))
(defun semantic-elisp-use-read (sl)
"Use `read' on the semantic list SL.
Return a bovination list to use."
(let* ((start (car sl))
(end (cdr sl))
(form (read (buffer-substring start end))))
(cond
;; If the first elt is a list, then it is some arbitrary code.
((listp (car form))
(semantic-tag-new-code "anonymous" nil)
)
;; A special form parser is provided, use it.
((and (car form) (symbolp (car form))
(get (car form) 'semantic-elisp-form-parser))
(funcall (get (car form) 'semantic-elisp-form-parser)
form start end))
;; Produce a generic code tag by default.
(t
(semantic-tag-new-code (format "%S" (car form)) nil)
))))
;;; Form parsers
;;
(semantic-elisp-setup-form-parser
(lambda (form start end)
(semantic-tag-new-function
(symbol-name (nth 2 form))
nil
'("form" "start" "end")
:form-parser t
))
semantic-elisp-setup-form-parser)
(semantic-elisp-setup-form-parser
(lambda (form start end)
(let ((tags
(condition-case foo
(semantic-parse-region start end nil 1)
(error (message "MUNGE: %S" foo)
nil))))
(if (semantic-tag-p (car-safe tags))
tags
(semantic-tag-new-code (format "%S" (car form)) nil))))
eval-and-compile
eval-when-compile
)
(semantic-elisp-setup-form-parser
(lambda (form start end)
(semantic-tag-new-function
(symbol-name (nth 1 form))
nil
(semantic-elisp-desymbolify (nth 2 form))
:user-visible-flag (eq (car-safe (nth 4 form)) 'interactive)
:documentation (semantic-elisp-do-doc (nth 3 form))
:overloadable (eq (car form) 'define-overload)
))
defun
defun*
defsubst
defmacro
define-overload
)
(semantic-elisp-setup-form-parser
(lambda (form start end)
(let ((doc (semantic-elisp-form-to-doc-string (nth 3 form))))
(semantic-tag-new-variable
(symbol-name (nth 1 form))
nil
(nth 2 form)
:user-visible-flag (and doc
(> (length doc) 0)
(= (aref doc 0) ?*))
:constant-flag (eq (car form) 'defconst)
:documentation (semantic-elisp-do-doc doc)
)))
defvar
defconst
defcustom
defface
defimage
defezimage
)
(semantic-elisp-setup-form-parser
(lambda (form start end)
(semantic-tag-new-function
(symbol-name (cadr (cadr form)))
nil nil
:user-visible-flag (and (nth 4 form)
(not (eq (nth 4 form) 'nil)))
:prototype-flag t
:documentation (semantic-elisp-do-doc (nth 3 form))))
autoload
)
(semantic-elisp-setup-form-parser
(lambda (form start end)
(let* ((a2 (nth 2 form))
(a3 (nth 3 form))
(args (if (listp a2) a2 a3))
(doc (nth (if (listp a2) 3 4) form)))
(semantic-tag-new-function
(symbol-name (nth 1 form))
nil
(if (listp (car args))
(cons (symbol-name (caar args))
(semantic-elisp-desymbolify (cdr args)))
(semantic-elisp-desymbolify (cdr args)))
:parent (if (listp (car args)) (symbol-name (cadr (car args))) nil)
:documentation (semantic-elisp-do-doc doc)
)))
defmethod
defgeneric
)
(semantic-elisp-setup-form-parser
(lambda (form start end)
(semantic-tag-new-function
(symbol-name (nth 1 form))
nil
(semantic-elisp-desymbolify (nth 2 form))
))
defadvice
)
(semantic-elisp-setup-form-parser
(lambda (form start end)
(let ((docpart (nthcdr 4 form)))
(semantic-tag-new-type
(symbol-name (nth 1 form))
"class"
(semantic-elisp-clos-args-to-semantic (nth 3 form))
(semantic-elisp-desymbolify (nth 2 form))
:typemodifiers (semantic-elisp-desymbolify
(unless (stringp (car docpart)) docpart))
:documentation (semantic-elisp-do-doc
(if (stringp (car docpart))
(car docpart)
(cadr (member :documentation docpart))))
)))
defclass
)
(semantic-elisp-setup-form-parser
(lambda (form start end)
(let ((slots (nthcdr 2 form)))
;; Skip doc string if present.
(and (stringp (car slots))
(setq slots (cdr slots)))
(semantic-tag-new-type
(symbol-name (if (consp (nth 1 form))
(car (nth 1 form))
(nth 1 form)))
"struct"
(semantic-elisp-desymbolify slots)
(cons nil nil)
)))
defstruct
)
(semantic-elisp-setup-form-parser
(lambda (form start end)
(semantic-tag-new-function
(symbol-name (nth 1 form))
nil nil
:lexical-analyzer-flag t
:documentation (semantic-elisp-do-doc (nth 2 form))
))
define-lex
)
(semantic-elisp-setup-form-parser
(lambda (form start end)
(let ((args (nth 3 form)))
(semantic-tag-new-function
(symbol-name (nth 1 form))
nil
(and (listp args) (semantic-elisp-desymbolify args))
:override-function-flag t
:parent (symbol-name (nth 2 form))
:documentation (semantic-elisp-do-doc (nth 4 form))
)))
define-mode-overload-implementation ;; obsoleted
define-mode-local-override
)
(semantic-elisp-setup-form-parser
(lambda (form start end)
(semantic-tag-new-variable
(symbol-name (nth 2 form))
nil
(nth 3 form) ; default value
:override-variable-flag t
:parent (symbol-name (nth 1 form))
:documentation (semantic-elisp-do-doc (nth 4 form))
))
defvar-mode-local
)
(semantic-elisp-setup-form-parser
(lambda (form start end)
(let ((name (nth 1 form)))
(semantic-tag-new-include
(symbol-name (if (eq (car-safe name) 'quote)
(nth 1 name)
name))
nil
:directory (nth 2 form))))
require
)
(semantic-elisp-setup-form-parser
(lambda (form start end)
(let ((name (nth 1 form)))
(semantic-tag-new-package
(symbol-name (if (eq (car-safe name) 'quote)
(nth 1 name)
name))
(nth 3 form))))
provide
)
;;; Mode setup
;;
(define-mode-local-override semantic-dependency-tag-file
emacs-lisp-mode (tag)
"Find the file BUFFER depends on described by TAG."
(let ((f (file-name-sans-extension
(locate-library (semantic-tag-name tag)))))
(concat f ".el")))
(defun semantic-emacs-lisp-overridable-doc (tag)
"Return the documentation string generated for overloadable functions.
Fetch the item for TAG. Only returns info about what symbols can be
used to perform the override."
(if (and (eq (semantic-tag-class tag) 'function)
(semantic-tag-get-attribute tag :overloadable))
;; Calc the doc to use for the overloadable symbols.
(overload-docstring-extension (intern (semantic-tag-name tag)))
""))
(defun semantic-emacs-lisp-obsoleted-doc (tag)
"Indicate that TAG is a new name that has obsoleted some old name.
Unfortunately, this requires that the tag in question has been loaded
into Emacs Lisp's memory."
(let ((obsoletethis (intern-soft (semantic-tag-name tag)))
(obsoletor nil))
;; This asks if our tag is available in the Emacs name space for querying.
(when obsoletethis
(mapatoms (lambda (a)
(let ((oi (get a 'byte-obsolete-info)))
(if (and oi (eq (car oi) obsoletethis))
(setq obsoletor a)))))
(if obsoletor
(format "\n at obsolete{%s,%s}" obsoletor (semantic-tag-name tag))
""))))
(define-mode-local-override semantic-documentation-for-tag
emacs-lisp-mode (tag &optional nosnarf)
"Return the documentation string for TAG.
Optional argument NOSNARF is ignored."
(let ((d (semantic-tag-docstring tag)))
(when (not d)
(cond ((semantic-tag-buffer tag)
;; Doc isn't in the tag itself. Lets pull it out of the
;; sources.
(let ((semantic-elisp-store-documentation-in-tag t))
(setq tag (with-current-buffer (semantic-tag-buffer tag)
(goto-char (semantic-tag-start tag))
(semantic-elisp-use-read
;; concoct a lexical token.
(cons (semantic-tag-start tag)
(semantic-tag-end tag))))
d (semantic-tag-docstring tag))))
;; The tag may be the result of a system search.
((intern-soft (semantic-tag-name tag))
(let ((sym (intern-soft (semantic-tag-name tag))))
;; Query into the global table o stuff.
(cond ((eq (semantic-tag-class tag) 'function)
(setq d (documentation sym)))
(t
(setq d (documentation-property
sym 'variable-documentation)))))
;; Label it as system doc.. perhaps just for debugging
;; purposes.
(if d (setq d (concat "Sytem Doc: \n" d)))
))
)
(when d
(concat
(substitute-command-keys
(if (and (> (length d) 0) (= (aref d 0) ?*))
(substring d 1)
d))
(semantic-emacs-lisp-overridable-doc tag)
(semantic-emacs-lisp-obsoleted-doc tag)))))
(define-mode-local-override semantic-insert-foreign-tag
emacs-lisp-mode (tag tagfile)
"Insert TAG from TAGFILE at point.
Attempts a simple prototype for calling or using TAG."
(cond ((semantic-tag-of-class-p tag 'function)
(insert "(" (semantic-tag-name tag) " )")
(forward-char -1))
(t
(insert (semantic-tag-name tag)))))
(define-mode-local-override semantic-tag-protection
emacs-lisp-mode (tag &optional parent)
"Return the protection of TAG in PARENT.
Override function for `semantic-tag-protection'."
(let ((prot (semantic-tag-get-attribute tag :protection)))
(cond
;; If a protection is not specified, AND there is a parent
;; data type, then it is public.
((and (not prot) parent) 'public)
((string= prot ":public") 'public)
((string= prot "public") 'public)
((string= prot ":private") 'private)
((string= prot "private") 'private)
((string= prot ":protected") 'protected)
((string= prot "protected") 'protected))))
(define-mode-local-override semantic-tag-static-p
emacs-lisp-mode (tag &optional parent)
"Return non-nil if TAG is static in PARENT class.
Overrides `semantic-nonterminal-static'."
;; This can only be true (theoretically) in a class where it is assigned.
(semantic-tag-get-attribute tag :static-flag))
;;; Context parsing
;;
;; Emacs lisp is very different from C,C++ which most context parsing
;; functions are written. Support them here.
(define-mode-local-override semantic-up-context emacs-lisp-mode
(&optional point bounds-type)
"Move up one context in an Emacs Lisp function.
A Context in many languages is a block with it's own local variables.
In Emacs, we will move up lists and stop when one starts with one of
the following context specifiers:
`let', `let*', `defun', `with-slots'
Returns non-nil it is not possible to go up a context."
(let ((last-up (semantic-up-context-default)))
(while
(and (not (looking-at
"(\\(let\\*?\\|def\\(un\\|method\\|generic\\|\
define-mode-overload\\)\
\\|with-slots\\)"))
(not last-up))
(setq last-up (semantic-up-context-default)))
last-up))
(define-mode-local-override semantic-get-local-variables emacs-lisp-mode
(&optional point)
"Return a list of local variables for POINT.
Scan backwards from point at each successive function. For all occurances
of `let' or `let*', grab those variable names."
(let* ((vars nil)
(fn nil))
(save-excursion
(while (setq fn (car (semantic-ctxt-current-function)))
(when (member fn '("let" "let*"))
;; Snarf variables
(up-list -1)
(forward-char 1)
(forward-word 1)
(skip-chars-forward "* \t\n")
(let ((varlst (read (buffer-substring (point)
(save-excursion
(forward-sexp 1)
(point))))))
(while varlst
(let* ((oneelt (car varlst))
(name (if (symbolp oneelt)
oneelt
(car oneelt))))
(setq vars (cons (semantic-tag-new-variable
(symbol-name name)
nil nil)
vars)))
(setq varlst (cdr varlst)))
))
(up-list -1)))
(nreverse vars)))
(define-mode-local-override semantic-end-of-command emacs-lisp-mode
()
"Move cursor to the end of the current command.
In emacs lisp this is easilly defined by parenthisis bounding."
(condition-case nil
(up-list 1)
(error nil)))
(define-mode-local-override semantic-beginning-of-command emacs-lisp-mode
()
"Move cursor to the beginning of the current command.
In emacs lisp this is easilly defined by parenthisis bounding."
(condition-case nil
(progn
(up-list -1)
(forward-char 1))
(error nil)))
(define-mode-local-override semantic-ctxt-current-symbol emacs-lisp-mode
(&optional point)
"List the symbol under point."
(save-excursion
(if point (goto-char point))
(require 'thingatpt)
(let ((sym (thing-at-point 'symbol)))
(if sym (list sym)))
))
(define-mode-local-override semantic-ctxt-current-function emacs-lisp-mode
(&optional point)
"Return a string which is the current function being called."
(save-excursion
(if point (goto-char point) (setq point (point)))
;; (semantic-beginning-of-command)
(if (condition-case nil
(and (save-excursion
(up-list -2)
(looking-at "(("))
(save-excursion
(up-list -3)
(looking-at "(let")))
(error nil))
;; This is really a let statement, not a function.
nil
(let ((fun (condition-case nil
(save-excursion
(up-list -1)
(forward-char 1)
(buffer-substring-no-properties
(point) (progn (forward-sexp 1)
(point))))
(error nil))
))
(when fun
;; Do not return FUN IFF the cursor is on FUN.
;; Huh? Thats because if cursor is on fun, it is
;; the current symbol, and not the current function.
(if (save-excursion
(condition-case nil
(progn (forward-sexp -1)
(and
(looking-at (regexp-quote fun))
(<= point (+ (point) (length fun))))
)
(error t)))
nil
;; We are ok, so get it.
(list fun))
))
)))
(define-mode-local-override semantic-ctxt-current-assignment emacs-lisp-mode
(&optional point)
"What is the variable being assigned into at POINT?"
(save-excursion
(if point (goto-char point))
(let ((fn (semantic-ctxt-current-function point))
(point (point)))
;; We should never get lists from here.
(if fn (setq fn (car fn)))
(cond
;; SETQ
((and fn (or (string= fn "setq") (string= fn "set")))
(save-excursion
(condition-case nil
(let ((count 0)
(lastodd nil)
(start nil))
(up-list -1)
(down-list 1)
(forward-sexp 1)
;; Skip over sexp until we pass point.
(while (< (point) point)
(setq count (1+ count))
(forward-comment 1)
(setq start (point))
(forward-sexp 1)
(if (= (% count 2) 1)
(setq lastodd
(buffer-substring-no-properties start (point))))
)
(if lastodd (list lastodd))
)
(error nil))))
;; This obscure thing finds let statements.
((condition-case nil
(and
(save-excursion
(up-list -2)
(looking-at "(("))
(save-excursion
(up-list -3)
(looking-at "(let")))
(error nil))
(save-excursion
(semantic-beginning-of-command)
;; Use func finding code, since it is the same format.
(semantic-ctxt-current-symbol)))
;;
;; DEFAULT- nothing
(t nil))
)))
(define-mode-local-override semantic-ctxt-current-argument emacs-lisp-mode
(&optional point)
"Return the index into the argument the cursor is in, or nil."
(save-excursion
(if point (goto-char point))
(if (looking-at "\\<\\w")
(forward-char 1))
(let ((count 0))
(while (condition-case nil
(progn
(forward-sexp -1)
t)
(error nil))
(setq count (1+ count)))
(cond ((= count 0)
0)
(t (1- count))))
))
(define-mode-local-override semantic-ctxt-current-class-list emacs-lisp-mode
(&optional point)
"Return a list of tag classes allowed at POINT.
Emacs Lisp knows much more about the class of the tag needed to perform
completion than some langauges. We distincly know if we are to be
a function name, variable name, or any type of symbol. We could identify
fields and such to, but that is for some other day."
(save-excursion
(if point (goto-char point))
(setq point (point))
(condition-case nil
(let ((count 0))
(up-list -1)
(forward-char 1)
(while (< (point) point)
(setq count (1+ count))
(forward-sexp 1))
(if (= count 1)
'(function)
'(variable))
)
(error '(variable)))
))
(define-mode-local-override semantic-tag-include-filename emacs-lisp-mode
(tag)
"Return the name of the tag with .el appended.
If there is a detail, prepend that directory."
(let ((name (semantic-tag-name tag))
(detail (semantic-tag-get-attribute tag :directory)))
(concat (expand-file-name name detail) ".el")))
(define-mode-local-override semantic-format-tag-abbreviate emacs-lisp-mode
(tag &optional parent color)
"Return an abbreviated string describing tag."
(let ((class (semantic-tag-class tag))
(name (semantic-format-tag-name tag parent color))
str)
(cond
((eq class 'function)
(concat "(" name ")"))
(t
(semantic-format-tag-abbreviate-default tag parent color)))))
(define-mode-local-override semantic-format-tag-prototype emacs-lisp-mode
(tag &optional parent color)
"Return a prototype string describing tag.
In Emacs Lisp, a prototype for something may start (autoload ...).
This is certainly not expected if this is used to display a summary.
Make up something else. When we go to write something that needs
a real Emacs Lisp protype, we can fix it then."
(let ((class (semantic-tag-class tag))
(name (semantic-format-tag-name tag parent color))
str)
(cond
((eq class 'function)
(let* ((args (semantic-tag-function-arguments tag))
(argstr (semantic--format-tag-arguments args
#'identity
color)))
(concat "(" name (if args " " "")
argstr
")")))
(t
(semantic-format-tag-prototype-default tag parent color)))))
(define-mode-local-override semantic-format-tag-concise-prototype emacs-lisp-mode
(tag &optional parent color)
"Return a concise prototype string describing tag.
See `semantic-format-tag-prototype' for Emacs Lisp for more details."
(semantic-format-tag-prototype tag parent color))
(define-mode-local-override semantic-format-tag-uml-prototype emacs-lisp-mode
(tag &optional parent color)
"Return a uml prototype string describing tag.
See `semantic-format-tag-prototype' for Emacs Lisp for more details."
(semantic-format-tag-prototype tag parent color))
(defvar-mode-local emacs-lisp-mode semantic-lex-analyzer
'semantic-emacs-lisp-lexer)
(defvar-mode-local emacs-lisp-mode semantic--parse-table
semantic--elisp-parse-table)
(defvar-mode-local emacs-lisp-mode semantic-function-argument-separator
" ")
(defvar-mode-local emacs-lisp-mode semantic-function-argument-separation-character
" ")
(defvar-mode-local emacs-lisp-mode semantic-symbol->name-assoc-list
'(
(type . "Types")
(variable . "Variables")
(function . "Defuns")
(include . "Requires")
(package . "Provides")
))
(defvar-mode-local emacs-lisp-mode imenu-create-index-function
'semantic-create-imenu-index)
(define-child-mode lisp-mode emacs-lisp-mode
"Make `lisp-mode' inherits mode local behavior from `emacs-lisp-mode'.")
;;;###autoload
(defun semantic-default-elisp-setup ()
"Setup hook function for Emacs Lisp files and Semantic."
)
;;;###autoload
(add-hook 'emacs-lisp-mode-hook 'semantic-default-elisp-setup)
;;; LISP MODE
;;
;; @TODO: Lisp supports syntaxes that Emacs Lisp does not.
;; Write a Lisp only parser someday.
;;
;; See this syntax:
;; (defun foo () /#A)
;;
;;;###autoload
(add-hook 'lisp-mode-hook 'semantic-default-elisp-setup)
;;;###autoload
(eval-after-load "semanticdb"
'(require 'semanticdb-el)
)
(provide 'semantic-el)
;;; semantic-el.el ends here
1.1 XEmacs/packages/xemacs-packages/semantic/bovine/semantic-make.el.upstream
Index: semantic-make.el.upstream
===================================================================
;;; semantic-make.el --- Makefile parsing rules.
;; Copyright (C) 2000, 2001, 2002, 2003, 2004 Eric M. Ludlam
;; Author: Eric M. Ludlam <zappo at gnu.org>
;; X-RCS: $Id: semantic-make.el.upstream,v 1.1 2007/12/03 07:04:57 michaels Exp $
;; This file is not part of GNU Emacs.
;; Semantic-ex 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 software 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 GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;
;; Use the Semantic Bovinator to parse Makefiles.
;; Concocted as an experiment for nonstandard languages.
(require 'semantic)
(require 'semantic-make-by)
(require 'backquote)
(eval-when-compile
(require 'semantic-format)
(require 'semantic-analyze)
)
;;; Code:
(define-lex-simple-regex-analyzer semantic-lex-make-backslash-newline
"A line ending with a \ continues to the next line and is treated as whitespace."
"\\(\\\\\n\\s-*\\)" 'whitespace 1)
(define-lex-regex-analyzer semantic-lex-make-command
"A command in a Makefile consists of a line starting with TAB, and ending at the newline."
"^\\(\t\\)"
(let ((start (match-end 0)))
(while (progn (end-of-line)
(save-excursion (forward-char -1) (looking-at "\\\\")))
(forward-char 1))
(semantic-lex-push-token
(semantic-lex-token 'shell-command start (point)))))
(define-lex semantic-make-lexer
"Lexical analyzer for Makefiles."
semantic-lex-make-command
semantic-lex-make-backslash-newline
semantic-lex-whitespace
semantic-lex-newline
semantic-lex-symbol-or-keyword
semantic-lex-charquote
semantic-lex-paren-or-list
semantic-lex-close-paren
semantic-lex-string
semantic-lex-ignore-comments
semantic-lex-punctuation
semantic-lex-default-action)
(defun semantic-make-expand-tag (tag)
"Expand TAG into a list of equivalent tags, or nil."
(let ((name (semantic-tag-name tag))
xpand)
(and (consp name)
(memq (semantic-tag-class tag) '(function include))
(while name
(setq xpand (cons (semantic-tag-clone tag (car name)) xpand)
name (cdr name))))
xpand))
(define-mode-local-override semantic-get-local-variables
makefile-mode (&optional point)
"Override `semantic-get-local-variables' so it does not throw an error.
We never have local variables in Makefiles."
nil)
(define-mode-local-override semantic-ctxt-current-class-list
makefile-mode (&optional point)
"List of classes that are valid to place at point."
(let ((tag (semantic-current-tag)))
(when tag
(cond ((condition-case nil
(save-excursion
(condition-case nil (forward-sexp -1)
(error nil))
(forward-char -2)
(looking-at "\\$\\s("))
(error nil))
;; We are in a variable reference
'(variable))
((semantic-tag-of-class-p tag 'function)
;; Note: variables are handled above.
'(function filename))
((semantic-tag-of-class-p tag 'variable)
'(function filename))
))))
(define-mode-local-override semantic-format-tag-abbreviate
makefile-mode (tag &optional parent color)
"Return an abbreviated string describing tag for Makefiles."
(let ((class (semantic-tag-class tag))
(name (semantic-format-tag-name tag parent color))
)
(cond ((eq class 'function)
(concat name ":"))
((eq class 'filename)
(concat "./" name))
(t
(semantic-format-tag-abbreviate-default tag parent color)))))
(defvar-mode-local makefile-mode semantic-function-argument-separator
" "
"Separator used between dependencies to rules.")
(define-mode-local-override semantic-format-tag-prototype
makefile-mode (tag &optional parent color)
"Return a prototype string describing tag for Makefiles."
(let* ((class (semantic-tag-class tag))
(name (semantic-format-tag-name tag parent color))
)
(cond ((eq class 'function)
(concat name ": "
(semantic--format-tag-arguments
(semantic-tag-function-arguments tag)
#'semantic-format-tag-prototype
color)))
((eq class 'filename)
(concat "./" name))
(t
(semantic-format-tag-prototype-default tag parent color)))))
(define-mode-local-override semantic-format-tag-concise-prototype
makefile-mode (tag &optional parent color)
"Return a concise prototype string describing tag for Makefiles.
This is the same as a regular prototype."
(semantic-format-tag-prototype tag parent color))
(define-mode-local-override semantic-format-tag-uml-prototype
makefile-mode (tag &optional parent color)
"Return a UML prototype string describing tag for Makefiles.
This is the same as a regular prototype."
(semantic-format-tag-prototype tag parent color))
(define-mode-local-override semantic-analyze-possible-completions
makefile-mode (context)
"Return a list of possible completions in a Makefile.
Uses default implementation, and also gets a list of filenames."
(save-excursion
(set-buffer (oref context buffer))
(let* ((normal (semantic-analyze-possible-completions-default context))
(classes (oref context :prefixclass))
(filetags nil))
(when (memq 'filename classes)
(let* ((prefix (car (oref context :prefix)))
(completetext (cond ((semantic-tag-p prefix)
(semantic-tag-name prefix))
((stringp prefix)
prefix)
((stringp (car prefix))
(car prefix))))
(files (directory-files default-directory nil
(concat "^" completetext))))
(setq filetags (mapcar (lambda (f) (semantic-tag f 'filename))
files))))
;; Return the normal completions found, plus any filenames
;; that match.
(append normal filetags)
)))
;;;###autoload
(defun semantic-default-make-setup ()
"Set up a Makefile buffer for parsing with semantic."
(semantic-make-by--install-parser)
(setq semantic-symbol->name-assoc-list '((variable . "Variables")
(function . "Rules")
(include . "Dependencies")
;; File is a meta-type created
;; to represent completions
;; but not actually parsed.
(file . "File"))
semantic-case-fold t
semantic-tag-expand-function 'semantic-make-expand-tag
semantic-lex-syntax-modifications '((?. "_")
(?= ".")
(?/ "_")
(?$ ".")
(?+ ".")
(?\\ ".")
)
imenu-create-index-function 'semantic-create-imenu-index
)
(setq semantic-lex-analyzer #'semantic-make-lexer)
)
;;;###autoload
(add-hook 'makefile-mode-hook 'semantic-default-make-setup)
(provide 'semantic-make)
;;; semantic-make.el ends here
1.1 XEmacs/packages/xemacs-packages/semantic/bovine/semantic-scm.el.upstream
Index: semantic-scm.el.upstream
===================================================================
;;; semantic-scm.el --- Semantic details for Scheme (guile)
;;; Copyright (C) 2001, 2002, 2003, 2004 Eric M. Ludlam
;; Author: Eric M. Ludlam <zappo at gnu.org>
;; X-RCS: $Id: semantic-scm.el.upstream,v 1.1 2007/12/03 07:04:58 michaels Exp $
;; 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 software 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 GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;
;; Use the Semantic Bovinator for Scheme (guile)
(require 'semantic)
(require 'semantic-scm-by)
(require 'backquote)
(eval-when-compile
(require 'document)
(require 'semantic-format))
;;; Code:
(defcustom semantic-default-scheme-path '("/usr/share/guile/")
"Default set of include paths for scheme (guile) code.
Used by `semantic-inc' to define an include path. This should
probably do some sort of search to see what is actually on the local
machine."
:group 'scheme
:type '(repeat (string :tag "Path")))
(define-mode-local-override semantic-format-tag-prototype scheme-mode (tag)
"Return a prototype for the Emacs Lisp nonterminal TAG."
(let* ((tok (semantic-tag-class tag))
(args (semantic-tag-components tag))
)
(if (eq tok 'function)
(concat (semantic-tag-name tag) " ("
(mapconcat (lambda (a) a) args " ")
")")
(semantic-format-tag-prototype-default tag))))
(define-mode-local-override semantic-documentation-for-tag scheme-mode (tag &optional nosnarf)
"Return the documentation string for TAG.
Optional argument NOSNARF is ignored."
(let ((d (semantic-tag-docstring tag)))
(if (and d (> (length d) 0) (= (aref d 0) ?*))
(substring d 1)
d)))
(define-mode-local-override semantic-insert-foreign-tag scheme-mode (tag tagfile)
"Insert TAG from TAGFILE at point.
Attempts a simple prototype for calling or using TAG."
(cond ((eq (semantic-tag-class tag) 'function)
(insert "(" (semantic-tag-name tag) " )")
(forward-char -1))
(t
(insert (semantic-tag-name tag)))))
(define-lex semantic-scheme-lexer
"A simple lexical analyzer that handles simple buffers.
This lexer ignores comments and whitespace, and will return
syntax as specified by the syntax table."
semantic-lex-ignore-whitespace
semantic-lex-ignore-newline
semantic-lex-symbol-or-keyword
semantic-lex-charquote
semantic-lex-paren-or-list
semantic-lex-close-paren
semantic-lex-string
semantic-lex-ignore-comments
semantic-lex-punctuation
semantic-lex-default-action)
;;;###autoload
(defun semantic-default-scheme-setup ()
"Setup hook function for Emacs Lisp files and Semantic."
(semantic-scm-by--install-parser)
(setq semantic-symbol->name-assoc-list '( (variable . "Variables")
;;(type . "Types")
(function . "Functions")
(include . "Loads")
(package . "DefineModule"))
imenu-create-index-function 'semantic-create-imenu-index
semantic-dependency-include-path semantic-default-scheme-path
imenu-create-index-function 'semantic-create-imenu-index
document-comment-start ";;"
document-comment-line-prefix ";;"
document-comment-end "\n"
)
(setq semantic-lex-analyzer #'semantic-scheme-lexer)
)
;;;###autoload
(add-hook 'scheme-mode-hook 'semantic-default-scheme-setup)
(provide 'semantic-scm)
;;; semantic-scm.el ends here
More information about the XEmacs-CVS
mailing list