Mercurial > emacs
changeset 104452:688cf3b99678
lisp/cedet/semantic/bovine/c-by.el
lisp/cedet/semantic/bovine/c.el
lisp/cedet/semantic/bovine/debug.el
lisp/cedet/semantic/bovine/el.el
lisp/cedet/semantic/bovine/gcc.el
lisp/cedet/semantic/bovine/java.el
lisp/cedet/semantic/bovine/make-by.el
lisp/cedet/semantic/bovine/make.el
lisp/cedet/semantic/bovine/scm-by.el
lisp/cedet/semantic/bovine/scm.el: New files.
| author | Chong Yidong <cyd@stupidchicken.com> |
|---|---|
| date | Sat, 05 Sep 2009 20:47:41 +0000 |
| parents | 2858c6bcc446 |
| children | a19d1a45b823 |
| files | lisp/cedet/semantic/bovine/c-by.el lisp/cedet/semantic/bovine/c.el lisp/cedet/semantic/bovine/debug.el lisp/cedet/semantic/bovine/el.el lisp/cedet/semantic/bovine/gcc.el lisp/cedet/semantic/bovine/java.el lisp/cedet/semantic/bovine/make-by.el lisp/cedet/semantic/bovine/make.el lisp/cedet/semantic/bovine/scm-by.el lisp/cedet/semantic/bovine/scm.el |
| diffstat | 10 files changed, 6755 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/bovine/c-by.el Sat Sep 05 20:47:41 2009 +0000 @@ -0,0 +1,2200 @@ +;;; semantic/bovine/c-by.el --- Generated parser support file + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, +;;; 2007, 2008, 2009 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This file was generated from the grammar file semantic/bovine/c.by +;; in the CEDET repository. + +;;; Code: + +(eval-when-compile (require 'semantic/bovine)) +(declare-function semantic-c-reconstitute-token "semantic/bovine/c") +(declare-function semantic-c-reconstitute-template "semantic/bovine/c") +(declare-function semantic-expand-c-tag "semantic/bovine/c") + +(defconst semantic-c-by--keyword-table + (semantic-lex-make-keyword-table + '(("extern" . EXTERN) + ("static" . STATIC) + ("const" . CONST) + ("volatile" . VOLATILE) + ("register" . REGISTER) + ("signed" . SIGNED) + ("unsigned" . UNSIGNED) + ("inline" . INLINE) + ("virtual" . VIRTUAL) + ("mutable" . MUTABLE) + ("struct" . STRUCT) + ("union" . UNION) + ("enum" . ENUM) + ("typedef" . TYPEDEF) + ("class" . CLASS) + ("typename" . TYPENAME) + ("namespace" . NAMESPACE) + ("using" . USING) + ("new" . NEW) + ("delete" . DELETE) + ("template" . TEMPLATE) + ("throw" . THROW) + ("reentrant" . REENTRANT) + ("try" . TRY) + ("catch" . CATCH) + ("operator" . OPERATOR) + ("public" . PUBLIC) + ("private" . PRIVATE) + ("protected" . PROTECTED) + ("friend" . FRIEND) + ("if" . IF) + ("else" . ELSE) + ("do" . DO) + ("while" . WHILE) + ("for" . FOR) + ("switch" . SWITCH) + ("case" . CASE) + ("default" . DEFAULT) + ("return" . RETURN) + ("break" . BREAK) + ("continue" . CONTINUE) + ("sizeof" . SIZEOF) + ("void" . VOID) + ("char" . CHAR) + ("wchar_t" . WCHAR) + ("short" . SHORT) + ("int" . INT) + ("long" . LONG) + ("float" . FLOAT) + ("double" . DOUBLE) + ("bool" . BOOL) + ("_P" . UNDERP) + ("__P" . UNDERUNDERP)) + '(("__P" summary "Common macro to eliminate prototype compatibility on some compilers") + ("_P" summary "Common macro to eliminate prototype compatibility on some compilers") + ("bool" summary "Primitive boolean type") + ("double" summary "Primitive floating-point type (double-precision 64-bit IEEE 754)") + ("float" summary "Primitive floating-point type (single-precision 32-bit IEEE 754)") + ("long" summary "Integral primitive type (-9223372036854775808 to 9223372036854775807)") + ("int" summary "Integral Primitive Type: (-2147483648 to 2147483647)") + ("short" summary "Integral Primitive Type: (-32768 to 32767)") + ("wchar_t" summary "Wide Character Type") + ("char" summary "Integral Character Type: (0 to 256)") + ("void" summary "Built in typeless type: void") + ("sizeof" summary "Compile time macro: sizeof(<type or variable>) // size in bytes") + ("continue" summary "Non-local continue within a loop (for, do/while): continue;") + ("break" summary "Non-local exit within a loop or switch (for, do/while, switch): break;") + ("return" summary "return <value>;") + ("default" summary "switch (<variable>) { case <constvalue>: code; ... default: code; }") + ("case" summary "switch (<variable>) { case <constvalue>: code; ... default: code; }") + ("switch" summary "switch (<variable>) { case <constvalue>: code; ... default: code; }") + ("for" summary "for(<init>; <condition>; <increment>) { code }") + ("while" summary "do { code } while (<condition>); or while (<condition>) { code };") + ("do" summary " do { code } while (<condition>);") + ("else" summary "if (<condition>) { code } [ else { code } ]") + ("if" summary "if (<condition>) { code } [ else { code } ]") + ("friend" summary "friend class <CLASSNAME>") + ("catch" summary "try { <body> } catch { <catch code> }") + ("try" summary "try { <body> } catch { <catch code> }") + ("reentrant" summary "<type> <methoddef> (<method args>) reentrant ...") + ("throw" summary "<type> <methoddef> (<method args>) throw (<exception>) ...") + ("template" summary "template <class TYPE ...> TYPE_OR_FUNCTION") + ("delete" summary "delete <object>;") + ("new" summary "new <classname>();") + ("using" summary "using <namespace>;") + ("namespace" summary "Namespace Declaration: namespace <name> { ... };") + ("typename" summary "typename is used to handle a qualified name as a typename;") + ("class" summary "Class Declaration: class <name>[:parents] { ... };") + ("typedef" summary "Arbitrary Type Declaration: typedef <typedeclaration> <name>;") + ("enum" summary "Enumeration Type Declaration: enum [name] { ... };") + ("union" summary "Union Type Declaration: union [name] { ... };") + ("struct" summary "Structure Type Declaration: struct [name] { ... };") + ("mutable" summary "Member Declaration Modifier: mutable <type> <name> ...") + ("virtual" summary "Method Modifier: virtual <type> <name>(...) ...") + ("inline" summary "Function Modifier: inline <return type> <name>(...) {...};") + ("unsigned" summary "Numeric Type Modifier: unsigned <numeric type> <name> ...") + ("signed" summary "Numeric Type Modifier: signed <numeric type> <name> ...") + ("register" summary "Declaration Modifier: register <type> <name> ...") + ("volatile" summary "Declaration Modifier: volatile <type> <name> ...") + ("const" summary "Declaration Modifier: const <type> <name> ...") + ("static" summary "Declaration Modifier: static <type> <name> ...") + ("extern" summary "Declaration Modifier: extern <type> <name> ..."))) + "Table of language keywords.") + +(defconst semantic-c-by--token-table + (semantic-lex-make-type-table + '(("semantic-list" + (BRACKETS . "\\[\\]") + (PARENS . "()") + (VOID_BLCK . "^(void)$") + (BRACE_BLCK . "^{") + (PAREN_BLCK . "^(") + (BRACK_BLCK . "\\[.*\\]$")) + ("close-paren" + (RBRACE . "}") + (RPAREN . ")")) + ("open-paren" + (LBRACE . "{") + (LPAREN . "(")) + ("symbol" + (RESTRICT . "\\<\\(__\\)?restrict\\>")) + ("number" + (ZERO . "^0$")) + ("string" + (CPP . "\"C\\+\\+\"") + (C . "\"C\"")) + ("punctuation" + (OR . "\\`[|]\\'") + (HAT . "\\`\\^\\'") + (MOD . "\\`[%]\\'") + (TILDE . "\\`[~]\\'") + (COMA . "\\`[,]\\'") + (GREATER . "\\`[>]\\'") + (LESS . "\\`[<]\\'") + (EQUAL . "\\`[=]\\'") + (BANG . "\\`[!]\\'") + (MINUS . "\\`[-]\\'") + (PLUS . "\\`[+]\\'") + (DIVIDE . "\\`[/]\\'") + (AMPERSAND . "\\`[&]\\'") + (STAR . "\\`[*]\\'") + (SEMICOLON . "\\`[;]\\'") + (COLON . "\\`[:]\\'") + (PERIOD . "\\`[.]\\'") + (HASH . "\\`[#]\\'"))) + 'nil) + "Table of lexical tokens.") + +(defconst semantic-c-by--parse-table + `( + (bovine-toplevel + (declaration) + ) ;; end bovine-toplevel + + (bovine-inner-scope + (codeblock) + ) ;; end bovine-inner-scope + + (declaration + (macro) + (type) + (define) + (var-or-fun) + (extern-c) + (template) + (using) + ) ;; end declaration + + (codeblock + (define) + (codeblock-var-or-fun) + (type) + (using) + ) ;; end codeblock + + (extern-c-contents + (open-paren + ,(semantic-lambda + (list nil)) + ) + (declaration) + (close-paren + ,(semantic-lambda + (list nil)) + ) + ) ;; end extern-c-contents + + (extern-c + (EXTERN + string + "\"C\"" + semantic-list + ,(semantic-lambda + (semantic-tag + "C" + 'extern :members + (semantic-parse-region + (car + (nth 2 vals)) + (cdr + (nth 2 vals)) + 'extern-c-contents + 1))) + ) + (EXTERN + string + "\"C\\+\\+\"" + semantic-list + ,(semantic-lambda + (semantic-tag + "C" + 'extern :members + (semantic-parse-region + (car + (nth 2 vals)) + (cdr + (nth 2 vals)) + 'extern-c-contents + 1))) + ) + (EXTERN + string + "\"C\"" + ,(semantic-lambda + (list nil)) + ) + (EXTERN + string + "\"C\\+\\+\"" + ,(semantic-lambda + (list nil)) + ) + ) ;; end extern-c + + (macro + (spp-macro-def + ,(semantic-lambda + (semantic-tag-new-variable + (nth 0 vals) nil nil :constant-flag t)) + ) + (spp-system-include + ,(semantic-lambda + (semantic-tag-new-include + (nth 0 vals) t)) + ) + (spp-include + ,(semantic-lambda + (semantic-tag-new-include + (nth 0 vals) nil)) + ) + ) ;; end macro + + (define + (spp-macro-def + ,(semantic-lambda + (semantic-tag-new-variable + (nth 0 vals) nil nil :constant-flag t)) + ) + (spp-macro-undef + ,(semantic-lambda + (list nil)) + ) + ) ;; end define + + (unionparts + (semantic-list + ,(semantic-lambda + (semantic-parse-region + (car + (nth 0 vals)) + (cdr + (nth 0 vals)) + 'classsubparts + 1)) + ) + ) ;; end unionparts + + (opt-symbol + (symbol) + ( ;;EMPTY + ) + ) ;; end opt-symbol + + (classsubparts + (open-paren + "{" + ,(semantic-lambda + (list nil)) + ) + (close-paren + "}" + ,(semantic-lambda + (list nil)) + ) + (class-protection + opt-symbol + punctuation + "\\`[:]\\'" + ,(semantic-lambda + (semantic-tag + (car + (nth 0 vals)) + 'label)) + ) + (var-or-fun) + (FRIEND + func-decl + ,(semantic-lambda + (semantic-tag + (car + (nth 1 vals)) + 'friend)) + ) + (FRIEND + CLASS + symbol + ,(semantic-lambda + (semantic-tag + (nth 2 vals) + 'friend)) + ) + (type) + (define) + (template) + ( ;;EMPTY + ) + ) ;; end classsubparts + + (opt-class-parents + (punctuation + "\\`[:]\\'" + class-parents + opt-template-specifier + ,(semantic-lambda + (list + (nth 1 vals))) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end opt-class-parents + + (one-class-parent + (opt-class-protection + opt-class-declmods + namespace-symbol + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 2 vals)) + "class" nil nil :protection + (car + (nth 0 vals)))) + ) + (opt-class-declmods + opt-class-protection + namespace-symbol + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 2 vals)) + "class" nil nil :protection + (car + (nth 1 vals)))) + ) + ) ;; end one-class-parent + + (class-parents + (one-class-parent + punctuation + "\\`[,]\\'" + class-parents + ,(semantic-lambda + (cons + (nth 0 vals) + (nth 2 vals))) + ) + (one-class-parent + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end class-parents + + (opt-class-declmods + (class-declmods + opt-class-declmods + ,(semantic-lambda + (list nil)) + ) + ( ;;EMPTY + ) + ) ;; end opt-class-declmods + + (class-declmods + (VIRTUAL) + ) ;; end class-declmods + + (class-protection + (PUBLIC) + (PRIVATE) + (PROTECTED) + ) ;; end class-protection + + (opt-class-protection + (class-protection + ,(semantic-lambda + (nth 0 vals)) + ) + ( ;;EMPTY + ,(semantic-lambda + (list + "unspecified")) + ) + ) ;; end opt-class-protection + + (namespaceparts + (semantic-list + ,(semantic-lambda + (semantic-parse-region + (car + (nth 0 vals)) + (cdr + (nth 0 vals)) + 'namespacesubparts + 1)) + ) + ) ;; end namespaceparts + + (namespacesubparts + (open-paren + "{" + ,(semantic-lambda + (list nil)) + ) + (close-paren + "}" + ,(semantic-lambda + (list nil)) + ) + (type) + (var-or-fun) + (define) + (class-protection + punctuation + "\\`[:]\\'" + ,(semantic-lambda + (semantic-tag + (car + (nth 0 vals)) + 'label)) + ) + (template) + (using) + ( ;;EMPTY + ) + ) ;; end namespacesubparts + + (enumparts + (semantic-list + ,(semantic-lambda + (semantic-parse-region + (car + (nth 0 vals)) + (cdr + (nth 0 vals)) + 'enumsubparts + 1)) + ) + ) ;; end enumparts + + (enumsubparts + (symbol + opt-assign + ,(semantic-lambda + (semantic-tag-new-variable + (nth 0 vals) + "int" + (car + (nth 1 vals)) :constant-flag t)) + ) + (open-paren + "{" + ,(semantic-lambda + (list nil)) + ) + (close-paren + "}" + ,(semantic-lambda + (list nil)) + ) + (punctuation + "\\`[,]\\'" + ,(semantic-lambda + (list nil)) + ) + ) ;; end enumsubparts + + (opt-name + (symbol) + ( ;;EMPTY + ,(semantic-lambda + (list + "")) + ) + ) ;; end opt-name + + (typesimple + (struct-or-class + opt-class + opt-name + opt-template-specifier + opt-class-parents + semantic-list + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 2 vals)) + (car + (nth 0 vals)) + (let + ( + (semantic-c-classname + (cons + (car + (nth 2 vals)) + (car + (nth 0 vals))))) + (semantic-parse-region + (car + (nth 5 vals)) + (cdr + (nth 5 vals)) + 'classsubparts + 1)) + (nth 4 vals) :template-specifier + (nth 3 vals) :parent + (car + (nth 1 vals)))) + ) + (struct-or-class + opt-class + opt-name + opt-template-specifier + opt-class-parents + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 2 vals)) + (car + (nth 0 vals)) nil + (nth 4 vals) :template-specifier + (nth 3 vals) :prototype t :parent + (car + (nth 1 vals)))) + ) + (UNION + opt-class + opt-name + unionparts + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 2 vals)) + (nth 0 vals) + (nth 3 vals) nil :parent + (car + (nth 1 vals)))) + ) + (ENUM + opt-class + opt-name + enumparts + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 2 vals)) + (nth 0 vals) + (nth 3 vals) nil :parent + (car + (nth 1 vals)))) + ) + (TYPEDEF + declmods + typeformbase + cv-declmods + typedef-symbol-list + ,(semantic-lambda + (semantic-tag-new-type + (nth 4 vals) + (nth 0 vals) nil + (list + (nth 2 vals)))) + ) + ) ;; end typesimple + + (typedef-symbol-list + (typedefname + punctuation + "\\`[,]\\'" + typedef-symbol-list + ,(semantic-lambda + (cons + (nth 0 vals) + (nth 2 vals))) + ) + (typedefname + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end typedef-symbol-list + + (typedefname + (opt-stars + symbol + opt-bits + opt-array + ,(semantic-lambda + (list + (nth 0 vals) + (nth 1 vals))) + ) + ) ;; end typedefname + + (struct-or-class + (STRUCT) + (CLASS) + ) ;; end struct-or-class + + (type + (typesimple + punctuation + "\\`[;]\\'" + ,(semantic-lambda + (nth 0 vals)) + ) + (NAMESPACE + symbol + namespaceparts + ,(semantic-lambda + (semantic-tag-new-type + (nth 1 vals) + (nth 0 vals) + (nth 2 vals) nil)) + ) + (NAMESPACE + namespaceparts + ,(semantic-lambda + (semantic-tag-new-type + "unnamed" + (nth 0 vals) + (nth 1 vals) nil)) + ) + (NAMESPACE + symbol + punctuation + "\\`[=]\\'" + typeformbase + punctuation + "\\`[;]\\'" + ,(semantic-lambda + (semantic-tag-new-type + (nth 1 vals) + (nth 0 vals) + (list + (semantic-tag-new-type + (car + (nth 3 vals)) + (nth 0 vals) nil nil)) nil :kind + 'alias)) + ) + ) ;; end type + + (using + (USING + usingname + punctuation + "\\`[;]\\'" + ,(semantic-lambda + (semantic-tag + (car + (nth 1 vals)) + 'using :type + (nth 1 vals))) + ) + ) ;; end using + + (usingname + (typeformbase + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 0 vals)) + "class" nil nil :prototype t)) + ) + (NAMESPACE + typeformbase + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 1 vals)) + "namespace" nil nil :prototype t)) + ) + ) ;; end usingname + + (template + (TEMPLATE + template-specifier + opt-friend + template-definition + ,(semantic-lambda + (semantic-c-reconstitute-template + (nth 3 vals) + (nth 1 vals))) + ) + ) ;; end template + + (opt-friend + (FRIEND) + ( ;;EMPTY + ) + ) ;; end opt-friend + + (opt-template-specifier + (template-specifier + ,(semantic-lambda + (nth 0 vals)) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end opt-template-specifier + + (template-specifier + (punctuation + "\\`[<]\\'" + template-specifier-types + punctuation + "\\`[>]\\'" + ,(semantic-lambda + (nth 1 vals)) + ) + ) ;; end template-specifier + + (template-specifier-types + (template-var + template-specifier-type-list + ,(semantic-lambda + (cons + (nth 0 vals) + (nth 1 vals))) + ) + ( ;;EMPTY + ) + ) ;; end template-specifier-types + + (template-specifier-type-list + (punctuation + "\\`[,]\\'" + template-specifier-types + ,(semantic-lambda + (nth 1 vals)) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end template-specifier-type-list + + (template-var + (template-type + opt-template-equal + ,(semantic-lambda + (cons + (car + (nth 0 vals)) + (cdr + (nth 0 vals)))) + ) + (string + ,(semantic-lambda + (list + (nth 0 vals))) + ) + (number + ,(semantic-lambda + (list + (nth 0 vals))) + ) + (opt-stars + opt-ref + namespace-symbol + ,(semantic-lambda + (nth 2 vals)) + ) + (semantic-list + ,(semantic-lambda + (list + (nth 0 vals))) + ) + (SIZEOF + semantic-list + ,(semantic-lambda + (list + (nth 1 vals))) + ) + ) ;; end template-var + + (opt-template-equal + (punctuation + "\\`[=]\\'" + symbol + punctuation + "\\`[<]\\'" + template-specifier-types + punctuation + "\\`[>]\\'" + ,(semantic-lambda + (list + (nth 1 vals))) + ) + (punctuation + "\\`[=]\\'" + symbol + ,(semantic-lambda + (list + (nth 1 vals))) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end opt-template-equal + + (template-type + (CLASS + symbol + ,(semantic-lambda + (semantic-tag-new-type + (nth 1 vals) + "class" nil nil)) + ) + (STRUCT + symbol + ,(semantic-lambda + (semantic-tag-new-type + (nth 1 vals) + "struct" nil nil)) + ) + (TYPENAME + symbol + ,(semantic-lambda + (semantic-tag-new-type + (nth 1 vals) + "class" nil nil)) + ) + (declmods + typeformbase + cv-declmods + opt-stars + opt-ref + variablearg-opt-name + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 1 vals)) nil nil nil :constant-flag + (if + (member + "const" + (append + (nth 0 vals) + (nth 2 vals))) t nil) :typemodifiers + (delete + "const" + (append + (nth 0 vals) + (nth 2 vals))) :reference + (car + (nth 4 vals)) :pointer + (car + (nth 3 vals)))) + ) + ) ;; end template-type + + (template-definition + (type + ,(semantic-lambda + (nth 0 vals)) + ) + (var-or-fun + ,(semantic-lambda + (nth 0 vals)) + ) + ) ;; end template-definition + + (opt-stars + (punctuation + "\\`[*]\\'" + opt-starmod + opt-stars + ,(semantic-lambda + (list + (1+ + (car + (nth 2 vals))))) + ) + ( ;;EMPTY + ,(semantic-lambda + (list + 0)) + ) + ) ;; end opt-stars + + (opt-starmod + (STARMOD + opt-starmod + ,(semantic-lambda + (cons + (car + (nth 0 vals)) + (nth 1 vals))) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end opt-starmod + + (STARMOD + (CONST) + ) ;; end STARMOD + + (declmods + (DECLMOD + declmods + ,(semantic-lambda + (cons + (car + (nth 0 vals)) + (nth 1 vals))) + ) + (DECLMOD + ,(semantic-lambda + (nth 0 vals)) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end declmods + + (DECLMOD + (EXTERN) + (STATIC) + (CVDECLMOD) + (INLINE) + (REGISTER) + (FRIEND) + (TYPENAME) + (METADECLMOD) + (VIRTUAL) + ) ;; end DECLMOD + + (metadeclmod + (METADECLMOD + ,(semantic-lambda) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end metadeclmod + + (CVDECLMOD + (CONST) + (VOLATILE) + ) ;; end CVDECLMOD + + (cv-declmods + (CVDECLMOD + cv-declmods + ,(semantic-lambda + (cons + (car + (nth 0 vals)) + (nth 1 vals))) + ) + (CVDECLMOD + ,(semantic-lambda + (nth 0 vals)) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end cv-declmods + + (METADECLMOD + (VIRTUAL) + (MUTABLE) + ) ;; end METADECLMOD + + (opt-ref + (punctuation + "\\`[&]\\'" + ,(semantic-lambda + (list + 1)) + ) + ( ;;EMPTY + ,(semantic-lambda + (list + 0)) + ) + ) ;; end opt-ref + + (typeformbase + (typesimple + ,(semantic-lambda + (nth 0 vals)) + ) + (STRUCT + symbol + ,(semantic-lambda + (semantic-tag-new-type + (nth 1 vals) + (nth 0 vals) nil nil)) + ) + (UNION + symbol + ,(semantic-lambda + (semantic-tag-new-type + (nth 1 vals) + (nth 0 vals) nil nil)) + ) + (ENUM + symbol + ,(semantic-lambda + (semantic-tag-new-type + (nth 1 vals) + (nth 0 vals) nil nil)) + ) + (builtintype + ,(semantic-lambda + (nth 0 vals)) + ) + (symbol + template-specifier + ,(semantic-lambda + (semantic-tag-new-type + (nth 0 vals) + "class" nil nil :template-specifier + (nth 1 vals))) + ) + (namespace-symbol-for-typeformbase + opt-template-specifier + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 0 vals)) + "class" nil nil :template-specifier + (nth 1 vals))) + ) + (symbol + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end typeformbase + + (signedmod + (UNSIGNED) + (SIGNED) + ) ;; end signedmod + + (builtintype-types + (VOID) + (CHAR) + (WCHAR) + (SHORT + INT + ,(semantic-lambda + (list + (concat + (nth 0 vals) + " " + (nth 1 vals)))) + ) + (SHORT) + (INT) + (LONG + INT + ,(semantic-lambda + (list + (concat + (nth 0 vals) + " " + (nth 1 vals)))) + ) + (FLOAT) + (DOUBLE) + (BOOL) + (LONG + DOUBLE + ,(semantic-lambda + (list + (concat + (nth 0 vals) + " " + (nth 1 vals)))) + ) + (LONG + LONG + ,(semantic-lambda + (list + (concat + (nth 0 vals) + " " + (nth 1 vals)))) + ) + (LONG) + ) ;; end builtintype-types + + (builtintype + (signedmod + builtintype-types + ,(semantic-lambda + (list + (concat + (car + (nth 0 vals)) + " " + (car + (nth 1 vals))))) + ) + (builtintype-types + ,(semantic-lambda + (nth 0 vals)) + ) + (signedmod + ,(semantic-lambda + (list + (concat + (car + (nth 0 vals)) + " int"))) + ) + ) ;; end builtintype + + (codeblock-var-or-fun + (declmods + typeformbase + declmods + opt-ref + var-or-func-decl + ,(semantic-lambda + (semantic-c-reconstitute-token + (nth 4 vals) + (nth 0 vals) + (nth 1 vals))) + ) + ) ;; end codeblock-var-or-fun + + (var-or-fun + (codeblock-var-or-fun + ,(semantic-lambda + (nth 0 vals)) + ) + (declmods + var-or-func-decl + ,(semantic-lambda + (semantic-c-reconstitute-token + (nth 1 vals) + (nth 0 vals) nil)) + ) + ) ;; end var-or-fun + + (var-or-func-decl + (func-decl + ,(semantic-lambda + (nth 0 vals)) + ) + (var-decl + ,(semantic-lambda + (nth 0 vals)) + ) + ) ;; end var-or-func-decl + + (func-decl + (opt-stars + opt-class + opt-destructor + functionname + opt-template-specifier + opt-under-p + arg-list + opt-post-fcn-modifiers + opt-throw + opt-initializers + fun-or-proto-end + ,(semantic-lambda + (nth 3 vals) + (list + 'function + (nth 1 vals) + (nth 2 vals) + (nth 6 vals) + (nth 8 vals) + (nth 7 vals)) + (nth 0 vals) + (nth 10 vals) + (nth 4 vals)) + ) + (opt-stars + opt-class + opt-destructor + functionname + opt-template-specifier + opt-under-p + opt-post-fcn-modifiers + opt-throw + opt-initializers + fun-try-end + ,(semantic-lambda + (nth 3 vals) + (list + 'function + (nth 1 vals) + (nth 2 vals) nil + (nth 7 vals) + (nth 6 vals)) + (nth 0 vals) + (nth 9 vals) + (nth 4 vals)) + ) + ) ;; end func-decl + + (var-decl + (varnamelist + punctuation + "\\`[;]\\'" + ,(semantic-lambda + (list + (nth 0 vals) + 'variable)) + ) + ) ;; end var-decl + + (opt-under-p + (UNDERP + ,(semantic-lambda + (list nil)) + ) + (UNDERUNDERP + ,(semantic-lambda + (list nil)) + ) + ( ;;EMPTY + ) + ) ;; end opt-under-p + + (opt-initializers + (punctuation + "\\`[:]\\'" + namespace-symbol + semantic-list + opt-initializers) + (punctuation + "\\`[,]\\'" + namespace-symbol + semantic-list + opt-initializers) + ( ;;EMPTY + ) + ) ;; end opt-initializers + + (opt-post-fcn-modifiers + (post-fcn-modifiers + opt-post-fcn-modifiers + ,(semantic-lambda + (cons + (nth 0 vals) + (nth 1 vals))) + ) + ( ;;EMPTY + ,(semantic-lambda + (list nil)) + ) + ) ;; end opt-post-fcn-modifiers + + (post-fcn-modifiers + (REENTRANT) + (CONST) + ) ;; end post-fcn-modifiers + + (opt-throw + (THROW + semantic-list + ,(lambda (vals start end) + (semantic-bovinate-from-nonterminal + (car + (nth 1 vals)) + (cdr + (nth 1 vals)) + 'throw-exception-list)) + ) + ( ;;EMPTY + ) + ) ;; end opt-throw + + (throw-exception-list + (namespace-symbol + punctuation + "\\`[,]\\'" + throw-exception-list + ,(semantic-lambda + (cons + (car + (nth 0 vals)) + (nth 2 vals))) + ) + (namespace-symbol + close-paren + ")" + ,(semantic-lambda + (nth 0 vals)) + ) + (symbol + close-paren + ")" + ,(semantic-lambda + (list + (nth 0 vals))) + ) + (open-paren + "(" + throw-exception-list + ,(semantic-lambda + (nth 1 vals)) + ) + (close-paren + ")" + ,(semantic-lambda) + ) + ) ;; end throw-exception-list + + (opt-bits + (punctuation + "\\`[:]\\'" + number + ,(semantic-lambda + (list + (nth 1 vals))) + ) + ( ;;EMPTY + ,(semantic-lambda + (list nil)) + ) + ) ;; end opt-bits + + (opt-array + (semantic-list + "\\[.*\\]$" + opt-array + ,(semantic-lambda + (list + (cons + 1 + (car + (nth 1 vals))))) + ) + ( ;;EMPTY + ,(semantic-lambda + (list nil)) + ) + ) ;; end opt-array + + (opt-assign + (punctuation + "\\`[=]\\'" + expression + ,(semantic-lambda + (list + (nth 1 vals))) + ) + ( ;;EMPTY + ,(semantic-lambda + (list nil)) + ) + ) ;; end opt-assign + + (opt-restrict + (symbol + "\\<\\(__\\)?restrict\\>") + ( ;;EMPTY + ) + ) ;; end opt-restrict + + (varname + (opt-stars + opt-restrict + namespace-symbol + opt-bits + opt-array + opt-assign + ,(semantic-lambda + (nth 2 vals) + (nth 0 vals) + (nth 3 vals) + (nth 4 vals) + (nth 5 vals)) + ) + ) ;; end varname + + (variablearg + (declmods + typeformbase + cv-declmods + opt-ref + variablearg-opt-name + ,(semantic-lambda + (semantic-tag-new-variable + (list + (nth 4 vals)) + (nth 1 vals) nil :constant-flag + (if + (member + "const" + (append + (nth 0 vals) + (nth 2 vals))) t nil) :typemodifiers + (delete + "const" + (append + (nth 0 vals) + (nth 2 vals))) :reference + (car + (nth 3 vals)))) + ) + ) ;; end variablearg + + (variablearg-opt-name + (varname + ,(semantic-lambda + (nth 0 vals)) + ) + (opt-stars + ,(semantic-lambda + (list + "") + (nth 0 vals) + (list nil nil nil)) + ) + ) ;; end variablearg-opt-name + + (varnamelist + (opt-ref + varname + punctuation + "\\`[,]\\'" + varnamelist + ,(semantic-lambda + (cons + (nth 1 vals) + (nth 3 vals))) + ) + (opt-ref + varname + ,(semantic-lambda + (list + (nth 1 vals))) + ) + ) ;; end varnamelist + + (namespace-symbol + (symbol + opt-template-specifier + punctuation + "\\`[:]\\'" + punctuation + "\\`[:]\\'" + namespace-symbol + ,(semantic-lambda + (list + (concat + (nth 0 vals) + "::" + (car + (nth 4 vals))))) + ) + (symbol + opt-template-specifier + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end namespace-symbol + + (namespace-symbol-for-typeformbase + (symbol + opt-template-specifier + punctuation + "\\`[:]\\'" + punctuation + "\\`[:]\\'" + namespace-symbol-for-typeformbase + ,(semantic-lambda + (list + (concat + (nth 0 vals) + "::" + (car + (nth 4 vals))))) + ) + (symbol + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end namespace-symbol-for-typeformbase + + (namespace-opt-class + (symbol + punctuation + "\\`[:]\\'" + punctuation + "\\`[:]\\'" + namespace-opt-class + ,(semantic-lambda + (list + (concat + (nth 0 vals) + "::" + (car + (nth 3 vals))))) + ) + (symbol + opt-template-specifier + punctuation + "\\`[:]\\'" + punctuation + "\\`[:]\\'" + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end namespace-opt-class + + (opt-class + (namespace-opt-class + ,(semantic-lambda + (nth 0 vals)) + ) + ( ;;EMPTY + ,(semantic-lambda + (list nil)) + ) + ) ;; end opt-class + + (opt-destructor + (punctuation + "\\`[~]\\'" + ,(semantic-lambda + (list t)) + ) + ( ;;EMPTY + ,(semantic-lambda + (list nil)) + ) + ) ;; end opt-destructor + + (arg-list + (semantic-list + "^(" + knr-arguments + ,(semantic-lambda + (nth 1 vals)) + ) + (semantic-list + "^(" + ,(semantic-lambda + (semantic-parse-region + (car + (nth 0 vals)) + (cdr + (nth 0 vals)) + 'arg-sub-list + 1)) + ) + (semantic-list + "^(void)$" + ,(semantic-lambda) + ) + ) ;; end arg-list + + (knr-varnamelist + (varname + punctuation + "\\`[,]\\'" + knr-varnamelist + ,(semantic-lambda + (cons + (nth 0 vals) + (nth 2 vals))) + ) + (varname + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end knr-varnamelist + + (knr-one-variable-decl + (declmods + typeformbase + cv-declmods + knr-varnamelist + ,(semantic-lambda + (semantic-tag-new-variable + (nreverse + (nth 3 vals)) + (nth 1 vals) nil :constant-flag + (if + (member + "const" + (append + (nth 2 vals))) t nil) :typemodifiers + (delete + "const" + (nth 2 vals)))) + ) + ) ;; end knr-one-variable-decl + + (knr-arguments + (knr-one-variable-decl + punctuation + "\\`[;]\\'" + knr-arguments + ,(semantic-lambda + (append + (semantic-expand-c-tag + (nth 0 vals)) + (nth 2 vals))) + ) + (knr-one-variable-decl + punctuation + "\\`[;]\\'" + ,(semantic-lambda + (semantic-expand-c-tag + (nth 0 vals))) + ) + ) ;; end knr-arguments + + (arg-sub-list + (variablearg + ,(semantic-lambda + (nth 0 vals)) + ) + (punctuation + "\\`[.]\\'" + punctuation + "\\`[.]\\'" + punctuation + "\\`[.]\\'" + close-paren + ")" + ,(semantic-lambda + (semantic-tag-new-variable + "..." + "vararg" nil)) + ) + (punctuation + "\\`[,]\\'" + ,(semantic-lambda + (list nil)) + ) + (open-paren + "(" + ,(semantic-lambda + (list nil)) + ) + (close-paren + ")" + ,(semantic-lambda + (list nil)) + ) + ) ;; end arg-sub-list + + (operatorsym + (punctuation + "\\`[<]\\'" + punctuation + "\\`[<]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "<<=")) + ) + (punctuation + "\\`[>]\\'" + punctuation + "\\`[>]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + ">>=")) + ) + (punctuation + "\\`[<]\\'" + punctuation + "\\`[<]\\'" + ,(semantic-lambda + (list + "<<")) + ) + (punctuation + "\\`[>]\\'" + punctuation + "\\`[>]\\'" + ,(semantic-lambda + (list + ">>")) + ) + (punctuation + "\\`[=]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "==")) + ) + (punctuation + "\\`[<]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "<=")) + ) + (punctuation + "\\`[>]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + ">=")) + ) + (punctuation + "\\`[!]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "!=")) + ) + (punctuation + "\\`[+]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "+=")) + ) + (punctuation + "\\`[-]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "-=")) + ) + (punctuation + "\\`[*]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "*=")) + ) + (punctuation + "\\`[/]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "/=")) + ) + (punctuation + "\\`[%]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "%=")) + ) + (punctuation + "\\`[&]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "&=")) + ) + (punctuation + "\\`[|]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "|=")) + ) + (punctuation + "\\`[-]\\'" + punctuation + "\\`[>]\\'" + punctuation + "\\`[*]\\'" + ,(semantic-lambda + (list + "->*")) + ) + (punctuation + "\\`[-]\\'" + punctuation + "\\`[>]\\'" + ,(semantic-lambda + (list + "->")) + ) + (semantic-list + "()" + ,(semantic-lambda + (list + "()")) + ) + (semantic-list + "\\[\\]" + ,(semantic-lambda + (list + "[]")) + ) + (punctuation + "\\`[<]\\'") + (punctuation + "\\`[>]\\'") + (punctuation + "\\`[*]\\'") + (punctuation + "\\`[+]\\'" + punctuation + "\\`[+]\\'" + ,(semantic-lambda + (list + "++")) + ) + (punctuation + "\\`[+]\\'") + (punctuation + "\\`[-]\\'" + punctuation + "\\`[-]\\'" + ,(semantic-lambda + (list + "--")) + ) + (punctuation + "\\`[-]\\'") + (punctuation + "\\`[&]\\'" + punctuation + "\\`[&]\\'" + ,(semantic-lambda + (list + "&&")) + ) + (punctuation + "\\`[&]\\'") + (punctuation + "\\`[|]\\'" + punctuation + "\\`[|]\\'" + ,(semantic-lambda + (list + "||")) + ) + (punctuation + "\\`[|]\\'") + (punctuation + "\\`[/]\\'") + (punctuation + "\\`[=]\\'") + (punctuation + "\\`[!]\\'") + (punctuation + "\\`[~]\\'") + (punctuation + "\\`[%]\\'") + (punctuation + "\\`[,]\\'") + (punctuation + "\\`\\^\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "^=")) + ) + (punctuation + "\\`\\^\\'") + ) ;; end operatorsym + + (functionname + (OPERATOR + operatorsym + ,(semantic-lambda + (nth 1 vals)) + ) + (semantic-list + ,(lambda (vals start end) + (semantic-bovinate-from-nonterminal + (car + (nth 0 vals)) + (cdr + (nth 0 vals)) + 'function-pointer)) + ) + (symbol + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end functionname + + (function-pointer + (open-paren + "(" + punctuation + "\\`[*]\\'" + symbol + close-paren + ")" + ,(semantic-lambda + (list + (concat + "*" + (nth 2 vals)))) + ) + ) ;; end function-pointer + + (fun-or-proto-end + (punctuation + "\\`[;]\\'" + ,(semantic-lambda + (list t)) + ) + (semantic-list + ,(semantic-lambda + (list nil)) + ) + (punctuation + "\\`[=]\\'" + number + "^0$" + punctuation + "\\`[;]\\'" + ,(semantic-lambda + (list ':pure-virtual-flag)) + ) + (fun-try-end + ,(semantic-lambda + (list nil)) + ) + ) ;; end fun-or-proto-end + + (fun-try-end + (TRY + opt-initializers + semantic-list + "^{" + fun-try-several-catches + ,(semantic-lambda + (list nil)) + ) + ) ;; end fun-try-end + + (fun-try-several-catches + (CATCH + semantic-list + "^(" + semantic-list + "^{" + fun-try-several-catches + ,(semantic-lambda) + ) + (CATCH + semantic-list + "^{" + fun-try-several-catches + ,(semantic-lambda) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end fun-try-several-catches + + (type-cast + (semantic-list + ,(lambda (vals start end) + (semantic-bovinate-from-nonterminal + (car + (nth 0 vals)) + (cdr + (nth 0 vals)) + 'type-cast-list)) + ) + ) ;; end type-cast + + (type-cast-list + (open-paren + typeformbase + close-paren) + ) ;; end type-cast-list + + (opt-stuff-after-symbol + (semantic-list + "^(") + (semantic-list + "\\[.*\\]$") + ( ;;EMPTY + ) + ) ;; end opt-stuff-after-symbol + + (multi-stage-dereference + (namespace-symbol + opt-stuff-after-symbol + punctuation + "\\`[.]\\'" + multi-stage-dereference) + (namespace-symbol + opt-stuff-after-symbol + punctuation + "\\`[-]\\'" + punctuation + "\\`[>]\\'" + multi-stage-dereference) + (namespace-symbol + opt-stuff-after-symbol) + ) ;; end multi-stage-dereference + + (string-seq + (string + string-seq + ,(semantic-lambda + (list + (concat + (nth 0 vals) + (car + (nth 1 vals))))) + ) + (string + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end string-seq + + (expr-start + (punctuation + "\\`[-]\\'") + (punctuation + "\\`[+]\\'") + (punctuation + "\\`[*]\\'") + (punctuation + "\\`[&]\\'") + ) ;; end expr-start + + (expression + (number + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (multi-stage-dereference + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (NEW + multi-stage-dereference + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (NEW + builtintype-types + semantic-list + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (namespace-symbol + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (string-seq + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (type-cast + expression + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (semantic-list + expression + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (semantic-list + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (expr-start + expression + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + ) ;; end expression + ) + "Parser table.") + +(defun semantic-c-by--install-parser () + "Setup the Semantic Parser." + (setq semantic--parse-table semantic-c-by--parse-table + semantic-debug-parser-source "c.by" + semantic-debug-parser-class 'semantic-bovine-debug-parser + semantic-flex-keywords-obarray semantic-c-by--keyword-table + semantic-equivalent-major-modes '(c-mode c++-mode) + )) + + +;;; Analyzers +;; +(require 'semantic/lex) + + +;;; Epilogue +;; + +(provide 'semantic/bovine/c-by) + +;;; semantic/bovine/c-by.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/bovine/c.el Sat Sep 05 20:47:41 2009 +0000 @@ -0,0 +1,1714 @@ +;;; semantic/bovine/c.el --- Semantic details for C + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, +;;; 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Support for the C/C++ bovine parser for Semantic. +;; +;; @todo - can I support c++-font-lock-extra-types ? + +(require 'semantic) +(require 'semantic/analyze) +(require 'semantic/bovine/gcc) +(require 'semantic/format) +(require 'semantic/idle) +(require 'semantic/lex-spp) +(require 'backquote) +(require 'semantic/bovine/c-by) + +(eval-when-compile + ;; For semantic-find-tags-* macros: + (require 'semantic/find)) + +(declare-function semantic-brute-find-tag-by-attribute "semantic/find") +(declare-function semanticdb-minor-mode-p "semantic/db-mode") +(declare-function semanticdb-file-table-object "semantic/db") +(declare-function semanticdb-needs-refresh-p "semantic/db") +(declare-function c-forward-conditional "cc-cmds") + +;;; Compatibility +;; +(eval-when-compile (require 'cc-mode)) + +(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)))) + ) + +;;; Code: +(define-child-mode c++-mode c-mode + "`c++-mode' uses the same parser as `c-mode'.") + + +;;; Include Paths +;; +(defcustom-mode-local-semantic-dependency-system-include-path + c-mode semantic-c-dependency-system-include-path + '("/usr/include") + "The system include path used by the C langauge.") + +(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.") + +;;; Compile Options +;; +;; Compiler options need to show up after path setup, but before +;; the preprocessor section. + +(when (member system-type '(gnu gnu/linux darwin cygwin)) + (semantic-gcc-setup)) + +;;; Pre-processor maps +;; +;;; Lexical analysis +(defvar semantic-lex-c-preprocessor-symbol-map-builtin + '( ("__THROW" . "") + ("__const" . "const") + ("__restrict" . "") + ("__declspec" . ((spp-arg-list ("foo") 1 . 2))) + ("__attribute__" . ((spp-arg-list ("foo") 1 . 2))) + ) + "List of symbols to include by default.") + +(defvar semantic-c-in-reset-preprocessor-table nil + "Non-nil while resetting the preprocessor symbol map. +Used to prevent a reset while trying to parse files that are +part of the preprocessor map.") + +(defvar semantic-lex-c-preprocessor-symbol-file) +(defvar semantic-lex-c-preprocessor-symbol-map) + +(defun semantic-c-reset-preprocessor-symbol-map () + "Reset the C preprocessor symbol map based on all input variables." + (when (featurep 'semantic-c) + (let ((filemap nil) + ) + (when (and (not semantic-c-in-reset-preprocessor-table) + (featurep 'semantic/db-mode) + (semanticdb-minor-mode-p)) + (let ( ;; Don't use external parsers. We need the internal one. + (semanticdb-out-of-buffer-create-table-fcn nil) + ;; Don't recurse while parsing these files the first time. + (semantic-c-in-reset-preprocessor-table t) + ) + (dolist (sf semantic-lex-c-preprocessor-symbol-file) + ;; Global map entries + (let* ((table (semanticdb-file-table-object sf t))) + (when table + (when (semanticdb-needs-refresh-p table) + (condition-case nil + ;; Call with FORCE, as the file is very likely to + ;; not be in a buffer. + (semanticdb-refresh-table table t) + (error (message "Error updating tables for %S" + (object-name table))))) + (setq filemap (append filemap (oref table lexical-table))) + ) + )))) + + (setq-mode-local c-mode + semantic-lex-spp-macro-symbol-obarray + (semantic-lex-make-spp-table + (append semantic-lex-c-preprocessor-symbol-map-builtin + semantic-lex-c-preprocessor-symbol-map + filemap)) + ) + ))) + +(defcustom semantic-lex-c-preprocessor-symbol-map nil + "Table of C Preprocessor keywords used by the Semantic C lexer. +Each entry is a cons cell like this: + ( \"KEYWORD\" . \"REPLACEMENT\" ) +Where KEYWORD is the macro that gets replaced in the lexical phase, +and REPLACEMENT is a string that is inserted in it's place. Empty string +implies that the lexical analyzer will discard KEYWORD when it is encountered. + +Alternately, it can be of the form: + ( \"KEYWORD\" ( LEXSYM1 \"str\" 1 1 ) ... ( LEXSYMN \"str\" 1 1 ) ) +where LEXSYM is a symbol that would normally be produced by the +lexical analyzer, such as `symbol' or `string'. The string in the +second position is the text that makes up the replacement. This is +the way to have multiple lexical symbols in a replacement. Using the +first way to specify text like \"foo::bar\" would not work, because : +is a sepearate lexical symbol. + +A quick way to see what you would need to insert is to place a +definition such as: + +#define MYSYM foo::bar + +into a C file, and do this: + \\[semantic-lex-spp-describe] + +The output table will describe the symbols needed." + :group 'c + :type '(repeat (cons (string :tag "Keyword") + (sexp :tag "Replacement"))) + :set (lambda (sym value) + (set-default sym value) + (condition-case nil + (semantic-c-reset-preprocessor-symbol-map) + (error nil)) + ) + ) + +(defcustom semantic-lex-c-preprocessor-symbol-file nil + "List of C/C++ files that contain preprocessor macros for the C lexer. +Each entry is a filename and each file is parsed, and those macros +are included in every C/C++ file parsed by semantic. +You can use this variable instead of `semantic-lex-c-preprocessor-symbol-map' +to store your global macros in a more natural way." + :group 'c + :type '(repeat (file :tag "File")) + :set (lambda (sym value) + (set-default sym value) + (condition-case nil + (semantic-c-reset-preprocessor-symbol-map) + (error nil)) + ) + ) + +(defcustom semantic-c-member-of-autocast 't + "Non-nil means classes with a '->' operator will cast to it's return type. + +For Examples: + + class Foo { + Bar *operator->(); + } + + Foo foo; + +if `semantic-c-member-of-autocast' is non-nil : + foo->[here completion will list method of Bar] + +if `semantic-c-member-of-autocast' is nil : + foo->[here completion will list method of Foo]" + :group 'c + :type 'boolean) + +(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-*#\\s-*define\\s-+\\(\\(\\sw\\|\\s_\\)+\\)" 1 + (goto-char (match-end 0)) + (skip-chars-forward " \t") + (if (eolp) + nil + (let* ((name (buffer-substring-no-properties + (match-beginning 1) (match-end 1))) + (with-args (save-excursion + (goto-char (match-end 0)) + (looking-at "("))) + (semantic-lex-spp-replacements-enabled nil) + ;; Temporarilly override the lexer to include + ;; special items needed inside a macro + (semantic-lex-analyzer #'semantic-cpp-lexer) + (raw-stream + (semantic-lex-spp-stream-for-macro (save-excursion + (semantic-c-end-of-macro) + (point)))) + ) + + ;; Only do argument checking if the paren was immediatly after + ;; the macro name. + (if with-args + (semantic-lex-spp-first-token-arg-list (car raw-stream))) + + ;; Magical spp variable for end point. + (setq semantic-lex-end-point (point)) + + ;; Handled nested macro streams. + (semantic-lex-spp-merge-streams raw-stream) + ))) + +(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-*#\\s-*undef\\s-+\\(\\(\\sw\\|\\s_\\)+\\)" 1) + + +;;; Conditional Skipping +;; +(defcustom semantic-c-obey-conditional-section-parsing-flag t + "*Non-nil means to interpret preprocessor #if sections. +This implies that some blocks of code will not be parsed based on the +values of the conditions in the #if blocks." + :group 'c + :type 'boolean) + +(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." + (require 'cc-cmds) + (let ((done nil)) + ;; (if (looking-at "^\\s-*#if") + ;; (semantic-lex-spp-push-if (point)) + (end-of-line) + (while (and semantic-c-obey-conditional-section-parsing-flag + (and (not done) + (re-search-forward + "^\\s-*#\\s-*\\(if\\(n?def\\)?\\|el\\(if\\|se\\)\\|endif\\)\\>" + nil t))) + (goto-char (match-beginning 0)) + (cond + ((looking-at "^\\s-*#\\s-*if") + ;; We found a nested if. Skip it. + (c-forward-conditional 1)) + ((looking-at "^\\s-*#\\s-*elif") + ;; We need to let the preprocessor analize this one. + (beginning-of-line) + (setq done t) + ) + ((looking-at "^\\s-*#\\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-*#\\s-*\\(if\\|ifndef\\|ifdef\\|elif\\)\\s-+\\(!?defined(\\|\\)\\s-*\\(\\(\\sw\\|\\s_\\)+\\)\\(\\s-*)\\)?\\s-*$" + (semantic-c-do-lex-if)) + +(defun semantic-c-do-lex-if () + "Handle lexical CPP if statements." + (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." + "^\\s-*#\\s-*\\(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." + "^\\s-*#\\s-*\\(if\\(n?def\\)?\\|endif\\|elif\\|else\\)" + (semantic-c-end-of-macro) + (setq semantic-lex-end-point (point)) + nil) + +(define-lex-spp-include-analyzer semantic-lex-c-include-system + "Identify include strings, and return special tokens." + "^\\s-*#\\s-*include\\s-*<\\([^ \t\n>]+\\)>" 0 + ;; Hit 1 is the name of the include. + (goto-char (match-end 0)) + (setq semantic-lex-end-point (point)) + (cons (buffer-substring-no-properties (match-beginning 1) + (match-end 1)) + 'system)) + +(define-lex-spp-include-analyzer semantic-lex-c-include + "Identify include strings, and return special tokens." + "^\\s-*#\\s-*include\\s-*\"\\([^ \t\n>]+\\)\"" 0 + ;; Hit 1 is the name of the include. + (goto-char (match-end 0)) + (setq semantic-lex-end-point (point)) + (cons (buffer-substring-no-properties (match-beginning 1) + (match-end 1)) + nil)) + + +(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-namespace-begin-macro + "Handle G++'s namespace macros which the pre-processor can't handle." + "\\(_GLIBCXX_BEGIN_NAMESPACE\\)(\\s-*\\(\\(?:\\w\\|\\s_\\)+\\)\\s-*)" + (let* ((nsend (match-end 1)) + (sym-start (match-beginning 2)) + (sym-end (match-end 2)) + (ms (buffer-substring-no-properties sym-start sym-end))) + ;; Push the namespace keyword. + (semantic-lex-push-token + (semantic-lex-token 'NAMESPACE (match-beginning 0) nsend "namespace")) + ;; Push the name. + (semantic-lex-push-token + (semantic-lex-token 'symbol sym-start sym-end ms)) + ) + (goto-char (match-end 0)) + (let ((start (point)) + (end 0)) + ;; If we can't find a matching end, then create the fake list. + (when (re-search-forward "_GLIBCXX_END_NAMESPACE" nil t) + (setq end (point)) + (semantic-lex-push-token + (semantic-lex-token 'semantic-list start end + (list 'prefix-fake))))) + (setq semantic-lex-end-point (point))) + +(defcustom semantic-lex-c-nested-namespace-ignore-second t + "Should _GLIBCXX_BEGIN_NESTED_NAMESPACE ignore the second namespace? +It is really there, but if a majority of uses is to squeeze out +the second namespace in use, then it should not be included. + +If you are having problems with smart completion and STL templates, +it may that this is set incorrectly. After changing the value +of this flag, you will need to delete any semanticdb cache files +that may have been incorrectly parsed." + :group 'semantic + :type 'boolean) + +(define-lex-regex-analyzer semantic-lex-c-VC++-begin-std-namespace + "Handle VC++'s definition of the std namespace." + "\\(_STD_BEGIN\\)" + (semantic-lex-push-token + (semantic-lex-token 'NAMESPACE (match-beginning 0) (match-end 0) "namespace")) + (semantic-lex-push-token + (semantic-lex-token 'symbol (match-beginning 0) (match-end 0) "std")) + (goto-char (match-end 0)) + (let ((start (point)) + (end 0)) + (when (re-search-forward "_STD_END" nil t) + (setq end (point)) + (semantic-lex-push-token + (semantic-lex-token 'semantic-list start end + (list 'prefix-fake))))) + (setq semantic-lex-end-point (point))) + +(define-lex-regex-analyzer semantic-lex-c-VC++-end-std-namespace + "Handle VC++'s definition of the std namespace." + "\\(_STD_END\\)" + (goto-char (match-end 0)) + (setq semantic-lex-end-point (point))) + +(define-lex-regex-analyzer semantic-lex-c-namespace-begin-nested-macro + "Handle G++'s namespace macros which the pre-processor can't handle." + "\\(_GLIBCXX_BEGIN_NESTED_NAMESPACE\\)(\\s-*\\(\\(?:\\w\\|\\s_\\)+\\)\\s-*,\\s-*\\(\\(?:\\w\\|\\s_\\)+\\)\\s-*)" + (goto-char (match-end 0)) + (let* ((nsend (match-end 1)) + (sym-start (match-beginning 2)) + (sym-end (match-end 2)) + (ms (buffer-substring-no-properties sym-start sym-end)) + (sym2-start (match-beginning 3)) + (sym2-end (match-end 3)) + (ms2 (buffer-substring-no-properties sym2-start sym2-end))) + ;; Push the namespace keyword. + (semantic-lex-push-token + (semantic-lex-token 'NAMESPACE (match-beginning 0) nsend "namespace")) + ;; Push the name. + (semantic-lex-push-token + (semantic-lex-token 'symbol sym-start sym-end ms)) + + (goto-char (match-end 0)) + (let ((start (point)) + (end 0)) + ;; If we can't find a matching end, then create the fake list. + (when (re-search-forward "_GLIBCXX_END_NESTED_NAMESPACE" nil t) + (setq end (point)) + (if semantic-lex-c-nested-namespace-ignore-second + ;; The same as _GLIBCXX_BEGIN_NAMESPACE + (semantic-lex-push-token + (semantic-lex-token 'semantic-list start end + (list 'prefix-fake))) + ;; Do both the top and second level namespace + (semantic-lex-push-token + (semantic-lex-token 'semantic-list start end + ;; We'll depend on a quick hack + (list 'prefix-fake-plus + (semantic-lex-token 'NAMESPACE + sym-end sym2-start + "namespace") + (semantic-lex-token 'symbol + sym2-start sym2-end + ms2) + (semantic-lex-token 'semantic-list start end + (list 'prefix-fake))) + ))) + ))) + (setq semantic-lex-end-point (point))) + +(define-lex-regex-analyzer semantic-lex-c-namespace-end-macro + "Handle G++'s namespace macros which the pre-processor can't handle." + "_GLIBCXX_END_\\(NESTED_\\)?NAMESPACE" + (goto-char (match-end 0)) + (setq semantic-lex-end-point (point))) + +(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-regex-analyzer semantic-c-lex-ignore-newline + "Detect and ignore newline tokens. +Use this ONLY if newlines are not whitespace characters (such as when +they are comment end characters)." + ;; Just like semantic-lex-ignore-newline, but also ignores + ;; trailing \. + "\\s-*\\\\?\\s-*\\(\n\\|\\s>\\)" + (setq semantic-lex-end-point (match-end 0))) + + +(define-lex semantic-c-lexer + "Lexical Analyzer for C code. +Use semantic-cpp-lexer for parsing text inside a CPP macro." + ;; 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 + semantic-lex-c-include-system + semantic-lex-c-ignore-ending-backslash + ;; Whitespace handling + semantic-lex-ignore-whitespace + semantic-c-lex-ignore-newline + ;; Non-preprocessor features + semantic-lex-number + ;; Must detect C strings before symbols because of possible L prefix! + semantic-lex-c-string + ;; Custom handlers for some macros come before the macro replacement analyzer. + semantic-lex-c-namespace-begin-macro + semantic-lex-c-namespace-begin-nested-macro + semantic-lex-c-namespace-end-macro + semantic-lex-c-VC++-begin-std-namespace + semantic-lex-c-VC++-end-std-namespace + ;; Handle macros, symbols, and keywords + 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) + +(define-lex-simple-regex-analyzer semantic-lex-cpp-hashhash + "Match ## inside a CPP macro as special." + "##" 'spp-concat) + +(define-lex semantic-cpp-lexer + "Lexical Analyzer for CPP macros in C code." + ;; CPP special + semantic-lex-cpp-hashhash + ;; 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 + semantic-lex-c-include-system + semantic-lex-c-ignore-ending-backslash + ;; Whitespace handling + semantic-lex-ignore-whitespace + semantic-c-lex-ignore-newline + ;; Non-preprocessor features + semantic-lex-number + ;; Must detect C strings before symbols because of possible L prefix! + semantic-lex-c-string + ;; Parsing inside a macro means that we don't do macro replacement. + ;; semantic-lex-spp-replace-or-symbol-or-keyword + semantic-lex-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) + +(define-mode-local-override semantic-parse-region c-mode + (start end &optional nonterminal depth returnonerror) + "Calls 'semantic-parse-region-default', except in a macro expansion. +MACRO expansion mode is handled through the nature of Emacs's non-lexical +binding of variables. +START, END, NONTERMINAL, DEPTH, and RETURNONERRORS are the same +as for the parent." + (if (and (boundp 'lse) (or (/= start 1) (/= end (point-max)))) + (let* ((last-lexical-token lse) + (llt-class (semantic-lex-token-class last-lexical-token)) + (llt-fakebits (car (cdr last-lexical-token))) + (macroexpand (stringp (car (cdr last-lexical-token))))) + (if macroexpand + (progn + ;; It is a macro expansion. Do something special. + ;;(message "MOOSE %S %S, %S : %S" start end nonterminal lse) + (semantic-c-parse-lexical-token + lse nonterminal depth returnonerror) + ) + ;; Not a macro expansion, but perhaps a funny semantic-list + ;; is at the start? Remove the depth if our semantic list is not + ;; made of list tokens. + (if (and depth (= depth 1) + (eq llt-class 'semantic-list) + (not (null llt-fakebits)) + (consp llt-fakebits) + (symbolp (car llt-fakebits)) + ) + (progn + (setq depth 0) + + ;; This is a copy of semantic-parse-region-default where we + ;; are doing something special with the lexication of the + ;; contents of the semantic-list token. Stuff not used by C + ;; removed. + (let ((tokstream + (if (and (consp llt-fakebits) + (eq (car llt-fakebits) 'prefix-fake-plus)) + ;; If our semantic-list is special, then only stick in the + ;; fake tokens. + (cdr llt-fakebits) + ;; Lex up the region with a depth of 0 + (semantic-lex start end 0)))) + + ;; Do the parse + (nreverse + (semantic-repeat-parse-whole-stream tokstream + nonterminal + returnonerror)) + + )) + + ;; It was not a macro expansion, nor a special semantic-list. + ;; Do old thing. + (semantic-parse-region-default start end + nonterminal depth + returnonerror) + ))) + ;; Do the parse + (semantic-parse-region-default start end nonterminal + depth returnonerror) + )) + +(defun semantic-c-parse-lexical-token (lexicaltoken nonterminal depth + returnonerror) + "Do a region parse on the contents of LEXICALTOKEN. +Presumably, this token has a string in it from a macro. +The text of the token is inserted into a different buffer, and +parsed there. +Argument NONTERMINAL, DEPTH, and RETURNONERROR are passed into +the regular parser." + (let* ((buf (get-buffer-create " *C parse hack*")) + (mode major-mode) + (spp-syms semantic-lex-spp-dynamic-macro-symbol-obarray) + (stream nil) + (start (semantic-lex-token-start lexicaltoken)) + (end (semantic-lex-token-end lexicaltoken)) + (symtext (semantic-lex-token-text lexicaltoken)) + (macros (get-text-property 0 'macros symtext)) + ) + (save-excursion + (set-buffer buf) + (erase-buffer) + (when (not (eq major-mode mode)) + (funcall mode) + ;; Hack in mode-local + (activate-mode-local-bindings) + ;; CHEATER! The following 3 lines are from + ;; `semantic-new-buffer-fcn', but we don't want to turn + ;; on all the other annoying modes for this little task. + (setq semantic-new-buffer-fcn-was-run t) + (semantic-lex-init) + (semantic-clear-toplevel-cache) + (remove-hook 'semantic-lex-reset-hooks 'semantic-lex-spp-reset-hook + t) + ) + ;; Get the macro symbol table right. + (setq semantic-lex-spp-dynamic-macro-symbol-obarray spp-syms) + ;; (message "%S" macros) + (dolist (sym macros) + (semantic-lex-spp-symbol-set (car sym) (cdr sym))) + + (insert symtext) + + (setq stream + (semantic-parse-region-default + (point-min) (point-max) nonterminal depth returnonerror)) + + ;; Clean up macro symbols + (dolist (sym macros) + (semantic-lex-spp-symbol-remove (car sym))) + + ;; Convert the text of the stream. + (dolist (tag stream) + ;; Only do two levels here 'cause I'm lazy. + (semantic--tag-set-overlay tag (list start end)) + (dolist (stag (semantic-tag-components-with-overlays tag)) + (semantic--tag-set-overlay stag (list start end)) + )) + ) + stream)) + +(defun semantic-expand-c-tag (tag) + "Expand TAG into a list of equivalent tags, or nil." + (let ((return-list nil) + ) + ;; Expand an EXTERN C first. + (when (eq (semantic-tag-class tag) 'extern) + (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))) + (setq return-list ret))) + + ;; Function or variables that have a :type that is some complex + ;; thing, extract it, and replace it with a reference. + ;; + ;; Thus, struct A { int a; } B; + ;; + ;; will create 2 toplevel tags, one is type A, and the other variable B + ;; where the :type of B is just a type tag A that is a prototype, and + ;; the actual struct info of A is it's own toplevel tag. + (when (or (semantic-tag-of-class-p tag 'function) + (semantic-tag-of-class-p tag 'variable)) + (let* ((basetype (semantic-tag-type tag)) + (typeref nil) + (tname (when (consp basetype) + (semantic-tag-name basetype)))) + ;; Make tname be a string. + (when (consp tname) (setq tname (car (car tname)))) + ;; Is the basetype a full type with a name of its own? + (when (and basetype (semantic-tag-p basetype) + (not (semantic-tag-prototype-p basetype)) + tname + (not (string= tname ""))) + ;; a type tag referencing the type we are extracting. + (setq typeref (semantic-tag-new-type + (semantic-tag-name basetype) + (semantic-tag-type basetype) + nil nil + :prototype t)) + ;; Convert original tag to only have a reference. + (setq tag (semantic-tag-copy tag)) + (semantic-tag-put-attribute tag :type typeref) + ;; Convert basetype to have the location information. + (semantic--tag-copy-properties tag basetype) + (semantic--tag-set-overlay basetype + (semantic-tag-overlay tag)) + ;; Store the base tag as part of the return list. + (setq return-list (cons basetype return-list))))) + + ;; Name of the tag is a list, so expand it. Tag lists occur + ;; for variables like this: int var1, var2, var3; + ;; + ;; This will expand that to 3 tags that happen to share the + ;; same overlay information. + (if (consp (semantic-tag-name tag)) + (let ((rl (semantic-expand-c-tag-namelist tag))) + (cond + ;; If this returns nothing, then return nil overall + ;; because that will restore the old TAG input. + ((not rl) (setq return-list nil)) + ;; If we have a return, append it to the existing list + ;; of returns. + ((consp rl) + (setq return-list (append rl return-list))) + )) + ;; If we didn't have a list, but the return-list is non-empty, + ;; that means we still need to take our existing tag, and glom + ;; it onto our extracted type. + (if (consp return-list) + (setq return-list (cons tag return-list))) + ) + + ;; Default, don't change the tag means returning nil. + return-list)) + +(defun semantic-expand-c-tag-namelist (tag) + "Expand TAG whose name is a list into a list of tags, or nil." + (cond ((semantic-tag-of-class-p 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)) + ;; Open up each name in the name list. + (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) + :reference (semantic-tag-get-attribute tag :reference) + :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))) + ;; Return the list + (nreverse vl))) + ((semantic-tag-of-class-p 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-get-attribute tag :superclasses) + ;;(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)) + (semantic-tag-of-class-p (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))) + +(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) + ;; Template specifier. + :template-specifier (nth 9 tokenpart) + ))) + ) + )) + +(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 +;; +(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-find-tags-by-scope-protection + c-mode (scopeprotection parent &optional table) + "Override the usual search for protection. +We can be more effective than the default by scanning through once, +and collecting tags based on the labels we see along the way." + (if (not table) (setq table (semantic-tag-type-members parent))) + (if (null scopeprotection) + table + (let ((ans nil) + (curprot 1) + (targetprot (cond ((eq scopeprotection 'public) + 1) + ((eq scopeprotection 'protected) + 2) + (t 3) + )) + (alist '(("public" . 1) + ("protected" . 2) + ("private" . 3))) + ) + (dolist (tag table) + (cond + ((semantic-tag-of-class-p tag 'label) + (setq curprot (cdr (assoc (semantic-tag-name tag) alist))) + ) + ((>= targetprot curprot) + (setq ans (cons tag ans))) + )) + ans))) + +(define-mode-local-override semantic-tag-protection + c-mode (tag &optional parent) + "Return the protection of TAG in PARENT. +Override function for `semantic-tag-protection'." + (let ((mods (semantic-tag-modifiers tag)) + (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) tag))) + (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. + (let ((sc (semantic-tag-get-attribute tag :typedef))) + (when (semantic-tag-p sc) (semantic-tag-components sc))) + (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)) + ;; @todo - Need to account for a parent that is a template + (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) + (require 'semantic/find) + (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)))) + +(defun semantic-c-dereference-typedef (type scope &optional type-declaration) + "If TYPE is a typedef, get TYPE's type by name or tag, and return. +SCOPE is not used, and TYPE-DECLARATION is used only if TYPE is not a typedef." + (if (and (eq (semantic-tag-class type) 'type) + (string= (semantic-tag-type type) "typedef")) + (let ((dt (semantic-tag-get-attribute type :typedef))) + (cond ((and (semantic-tag-p dt) + (not (semantic-analyze-tag-prototype-p dt))) + ;; In this case, DT was declared directly. We need + ;; to clone DT and apply a filename to it. + (let* ((fname (semantic-tag-file-name type)) + (def (semantic-tag-copy dt nil fname))) + (list def def))) + ((stringp dt) (list dt (semantic-tag dt 'type))) + ((consp dt) (list (car dt) dt)))) + + (list type type-declaration))) + +(defun semantic-c--instantiate-template (tag def-list spec-list) + "Replace TAG name according to template specification. +DEF-LIST is the template information. +SPEC-LIST is the template specifier of the datatype instantiated." + (when (and (car def-list) (car spec-list)) + + (when (and (string= (semantic-tag-type (car def-list)) "class") + (string= (semantic-tag-name tag) (semantic-tag-name (car def-list)))) + (semantic-tag-set-name tag (semantic-tag-name (car spec-list)))) + + (semantic-c--instantiate-template tag (cdr def-list) (cdr spec-list)))) + +(defun semantic-c--template-name-1 (spec-list) + "return a string used to compute template class name based on SPEC-LIST +for ref<Foo,Bar> it will return 'Foo,Bar'." + (when (car spec-list) + (let* ((endpart (semantic-c--template-name-1 (cdr spec-list))) + (separator (and endpart ","))) + (concat (semantic-tag-name (car spec-list)) separator endpart)))) + +(defun semantic-c--template-name (type spec-list) + "Return a template class name for TYPE based on SPEC-LIST. +For a type `ref' with a template specifier of (Foo Bar) it will +return 'ref<Foo,Bar>'." + (concat (semantic-tag-name type) + "<" (semantic-c--template-name-1 (cdr spec-list)) ">")) + +(defun semantic-c-dereference-template (type scope &optional type-declaration) + "Dereference any template specifieres in TYPE within SCOPE. +If TYPE is a template, return a TYPE copy with the templates types +instantiated as specified in TYPE-DECLARATION." + (when (semantic-tag-p type-declaration) + (let ((def-list (semantic-tag-get-attribute type :template)) + (spec-list (semantic-tag-get-attribute type-declaration :template-specifier))) + (when (and def-list spec-list) + (setq type (semantic-tag-deep-copy-one-tag + type + (lambda (tag) + (when (semantic-tag-of-class-p tag 'type) + (semantic-c--instantiate-template + tag def-list spec-list)) + tag) + )) + (semantic-tag-set-name type (semantic-c--template-name type spec-list)) + (semantic-tag-put-attribute type :template nil) + (semantic-tag-set-faux type)))) + (list type type-declaration)) + +;;; Patch here by "Raf" for instantiating templates. +(defun semantic-c-dereference-member-of (type scope &optional type-declaration) + "Dereference through the `->' operator of TYPE. +Uses the return type of the '->' operator if it is contained in TYPE. +SCOPE is the current local scope to perform searches in. +TYPE-DECLARATION is passed through." + (if semantic-c-member-of-autocast + (let ((operator (car (semantic-find-tags-by-name "->" (semantic-analyze-scoped-type-parts type))))) + (if operator + (list (semantic-tag-get-attribute operator :type) (semantic-tag-get-attribute operator :type)) + (list type type-declaration))) + (list type type-declaration))) + +;; David Engster: The following three functions deal with namespace +;; aliases and types which are member of a namespace through a using +;; statement. For examples, see the file semantic/tests/testusing.cpp, +;; tests 5 and following. + +(defun semantic-c-dereference-namespace (type scope &optional type-declaration) + "Dereference namespace which might hold an 'alias' for TYPE. +Such an alias can be created through 'using' statements in a +namespace declaration. This function checks the namespaces in +SCOPE for such statements." + (let ((scopetypes (oref scope scopetypes)) + typename currentns tmp usingname result namespaces) + (when (and (semantic-tag-p type-declaration) + (or (null type) (semantic-tag-prototype-p type))) + (setq typename (semantic-analyze-split-name (semantic-tag-name type-declaration))) + ;; If we already have that TYPE in SCOPE, we do nothing + (unless (semantic-deep-find-tags-by-name (or (car-safe typename) typename) scopetypes) + (if (stringp typename) + ;; The type isn't fully qualified, so we have to search in all namespaces in SCOPE. + (setq namespaces (semantic-find-tags-by-type "namespace" scopetypes)) + ;; This is a fully qualified name, so we only have to search one namespace. + (setq namespaces (semanticdb-typecache-find (car typename))) + ;; Make sure it's really a namespace. + (if (string= (semantic-tag-type namespaces) "namespace") + (setq namespaces (list namespaces)) + (setq namespaces nil))) + (setq result nil) + ;; Iterate over all the namespaces we have to check. + (while (and namespaces + (null result)) + (setq currentns (car namespaces)) + ;; Check if this is namespace is an alias and dereference it if necessary. + (setq result (semantic-c-dereference-namespace-alias type-declaration currentns)) + (unless result + ;; Otherwise, check if we can reach the type through 'using' statements. + (setq result + (semantic-c-check-type-namespace-using type-declaration currentns))) + (setq namespaces (cdr namespaces))))) + (if result + ;; we have found the original type + (list result result) + (list type type-declaration)))) + +(defun semantic-c-dereference-namespace-alias (type namespace) + "Dereference TYPE in NAMESPACE, given that NAMESPACE is an alias. +Checks if NAMESPACE is an alias and if so, returns a new type +with a fully qualified name in the original namespace. Returns +nil if NAMESPACE is not an alias." + (when (eq (semantic-tag-get-attribute namespace :kind) 'alias) + (let ((typename (semantic-analyze-split-name (semantic-tag-name type))) + ns newtype) + ;; Get name of namespace this one's an alias for. + (when + (setq ns (semantic-analyze-split-name + (semantic-tag-name + (car (semantic-tag-get-attribute namespace :members))))) + ;; Construct new type with name in original namespace. + (setq newtype + (semantic-tag-clone + type + (semantic-analyze-unsplit-name + (if (listp ns) + (append (butlast ns) (last typename)) + (append (list ns) (last typename)))))))))) + +;; This searches a type in a namespace, following through all using +;; statements. +(defun semantic-c-check-type-namespace-using (type namespace) + "Check if TYPE is accessible in NAMESPACE through a using statement. +Returns the original type from the namespace where it is defined, +or nil if it cannot be found." + (let (usings result usingname usingtype unqualifiedname members shortname tmp) + ;; Get all using statements from NAMESPACE. + (when (and (setq usings (semantic-tag-get-attribute namespace :members)) + (setq usings (semantic-find-tags-by-class 'using usings))) + ;; Get unqualified typename. + (when (listp (setq unqualifiedname (semantic-analyze-split-name + (semantic-tag-name type)))) + (setq unqualifiedname (car (last unqualifiedname)))) + ;; Iterate over all using statements in NAMESPACE. + (while (and usings + (null result)) + (setq usingname (semantic-analyze-split-name + (semantic-tag-name (car usings))) + usingtype (semantic-tag-type (semantic-tag-type (car usings)))) + (cond + ((or (string= usingtype "namespace") + (stringp usingname)) + ;; We are dealing with a 'using [namespace] NAMESPACE;' + ;; Search for TYPE in that namespace + (setq result + (semanticdb-typecache-find usingname)) + (if (and result + (setq members (semantic-tag-get-attribute result :members)) + (setq members (semantic-find-tags-by-name unqualifiedname members))) + ;; TYPE is member of that namespace, so we are finished + (setq result (car members)) + ;; otherwise recursively search in that namespace for an alias + (setq result (semantic-c-check-type-namespace-using type result)) + (when result + (setq result (semantic-tag-type result))))) + ((and (string= usingtype "class") + (listp usingname)) + ;; We are dealing with a 'using TYPE;' + (when (string= unqualifiedname (car (last usingname))) + ;; We have found the correct tag. + (setq result (semantic-tag-type (car usings)))))) + (setq usings (cdr usings)))) + result)) + + +(define-mode-local-override semantic-analyze-dereference-metatype + c-mode (type scope &optional type-declaration) + "Dereference TYPE as described in `semantic-analyze-dereference-metatype'. +Handle typedef, template instantiation, and '->' operator." + (let* ((dereferencer-list '(semantic-c-dereference-typedef + semantic-c-dereference-template + semantic-c-dereference-member-of + semantic-c-dereference-namespace)) + (dereferencer (pop dereferencer-list)) + (type-tuple) + (original-type type)) + (while dereferencer + (setq type-tuple (funcall dereferencer type scope type-declaration) + type (car type-tuple) + type-declaration (cadr type-tuple)) + (if (not (eq type original-type)) + ;; we found a new type so break the dereferencer loop now ! + ;; (we will be recalled with the new type expanded by + ;; semantic-analyze-dereference-metatype-stack). + (setq dereferencer nil) + ;; no new type found try the next dereferencer : + (setq dereferencer (pop dereferencer-list))))) + (list type type-declaration)) + +(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-analyze-unsplit-name c-mode (namelist) + "Assemble the list of names NAMELIST into a namespace name." + (mapconcat 'identity namelist "::")) + +(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 ((tagsaroundpoint (semantic-find-tag-by-overlay)) + (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 tmp (semantic-find-tags-by-name "unnamed" tmp)) + (setq tagreturn tmp) + ;; We should also find all "using" type statements and + ;; accept those entities in as well. + (setq tmp (semanticdb-find-tags-by-class 'using)) + (let ((idx 0) + (len (semanticdb-find-result-length tmp))) + (while (< idx len) + (setq tagreturn (cons (semantic-tag-type (car (semanticdb-find-result-nth tmp idx))) tagreturn)) + (setq idx (1+ idx))) + ) + ;; Use the encompased types around point to also look for using statements. + ;;(setq tagreturn (cons "bread_name" tagreturn)) + (while (cdr tagsaroundpoint) ; don't search the last one + (setq tmp (semantic-find-tags-by-class 'using (semantic-tag-components (car tagsaroundpoint)))) + (dolist (T tmp) + (setq tagreturn (cons (semantic-tag-type T) tagreturn)) + ) + (setq tagsaroundpoint (cdr tagsaroundpoint)) + ) + ;; If in a function... + (when (and (semantic-tag-of-class-p (car tagsaroundpoint) 'function) + ;; ...search for using statements in the local scope... + (setq tmp (semantic-find-tags-by-class + 'using + (semantic-get-local-variables)))) + ;; ... and add them. + (setq tagreturn + (append tagreturn + (mapcar 'semantic-tag-type tmp)))) + ;; Return the stuff + tagreturn + )) + +(define-mode-local-override semantic-get-local-variables c++-mode () + "Do what `semantic-get-local-variables' does, plus add `this' if needed." + (let* ((origvar (semantic-get-local-variables-default)) + (ct (semantic-current-tag)) + (p (semantic-tag-function-parent ct))) + ;; If we have a function parent, then that implies we can + (if (and p (semantic-tag-of-class-p ct 'function)) + ;; Append a new tag THIS into our space. + (cons (semantic-tag-new-variable "this" p nil) + origvar) + ;; No parent, just return the usual + origvar) + )) + +(define-mode-local-override semantic-idle-summary-current-symbol-info + c-mode () + "Handle the SPP keywords, then use the default mechanism." + (let* ((sym (car (semantic-ctxt-current-thing))) + (spp-sym (semantic-lex-spp-symbol sym))) + (if spp-sym + (let* ((txt (concat "Macro: " sym)) + (sv (symbol-value spp-sym)) + (arg (semantic-lex-spp-macro-with-args sv)) + ) + (when arg + (setq txt (concat txt (format "%S" arg))) + (setq sv (cdr sv))) + + ;; This is optional, and potentially fraught w/ errors. + (condition-case nil + (dolist (lt sv) + (setq txt (concat txt " " (semantic-lex-token-text lt)))) + (error (setq txt (concat txt " #error in summary fcn")))) + + txt) + (semantic-idle-summary-current-symbol-info-default)))) + +(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 given type, and a field.") + +(defvar-mode-local c-mode semantic-command-separation-character ";" + "Commen separation character for C") + +(defvar-mode-local c-mode senator-step-at-tag-classes '(function variable) + "Tag classes where senator will stop at the end.") + +(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) + (add-hook 'semantic-lex-reset-hooks 'semantic-lex-spp-reset-hook nil t) + ) + +(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)))) + + (semantic-c-reset-preprocessor-symbol-map) + ) + +(add-hook 'c-mode-hook 'semantic-default-c-setup) +(add-hook 'c++-mode-hook 'semantic-default-c-setup) + +;;; SETUP QUERY +;; +(defun semantic-c-describe-environment () + "Describe the Semantic features of the current C environment." + (interactive) + (if (not (or (eq major-mode 'c-mode) (eq major-mode 'c++-mode))) + (error "Not useful to query C mode in %s mode" major-mode)) + (let ((gcc (when (boundp 'semantic-gcc-setup-data) + semantic-gcc-setup-data)) + ) + (semantic-fetch-tags) + + (with-output-to-temp-buffer "*Semantic C Environment*" + (when gcc + (princ "Calculated GCC Parameters:") + (dolist (P gcc) + (princ "\n ") + (princ (car P)) + (princ " = ") + (princ (cdr P)) + ) + ) + + (princ "\n\nInclude Path Summary:\n") + (when ede-object + (princ "\n This file's project include is handled by:\n") + (princ " ") + (princ (object-print ede-object)) + (princ "\n with the system path:\n") + (dolist (dir (ede-system-include-path ede-object)) + (princ " ") + (princ dir) + (princ "\n")) + ) + + (when semantic-dependency-include-path + (princ "\n This file's generic include path is:\n") + (dolist (dir semantic-dependency-include-path) + (princ " ") + (princ dir) + (princ "\n"))) + + (when semantic-dependency-system-include-path + (princ "\n This file's system include path is:\n") + (dolist (dir semantic-dependency-system-include-path) + (princ " ") + (princ dir) + (princ "\n"))) + + (princ "\n\nMacro Summary:\n") + (when semantic-lex-c-preprocessor-symbol-file + (princ "\n Your CPP table is primed from these files:\n") + (dolist (file semantic-lex-c-preprocessor-symbol-file) + (princ " ") + (princ file) + (princ "\n") + (princ " in table: ") + (princ (object-print (semanticdb-file-table-object file))) + (princ "\n") + )) + + (when semantic-lex-c-preprocessor-symbol-map-builtin + (princ "\n Built-in symbol map:\n") + (dolist (S semantic-lex-c-preprocessor-symbol-map-builtin) + (princ " ") + (princ (car S)) + (princ " = ") + (princ (cdr S)) + (princ "\n") + )) + + (when semantic-lex-c-preprocessor-symbol-map + (princ "\n User symbol map:\n") + (dolist (S semantic-lex-c-preprocessor-symbol-map) + (princ " ") + (princ (car S)) + (princ " = ") + (princ (cdr S)) + (princ "\n") + )) + + (princ "\n\n Use: M-x semantic-lex-spp-describe RET\n") + (princ "\n to see the complete macro table.\n") + + ))) + +(provide 'semantic/bovine/c) + +(semantic-c-reset-preprocessor-symbol-map) + +;;; semantic/bovine/c.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/bovine/debug.el Sat Sep 05 20:47:41 2009 +0000 @@ -0,0 +1,147 @@ +;;; semantic/bovine/debug.el --- Debugger support for bovinator + +;;; Copyright (C) 2003 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Implementation of the semantic debug support framework for the +;; bovine parser. +;; + +(require 'semantic/debug) +(require 'semantic/find) + +;;; Code: + +;;; Support a frame for the Bovinator +;; +(defclass semantic-bovine-debug-frame (semantic-debug-frame) + ((nonterm :initarg :nonterm + :type symbol + :documentation + "The name of the semantic nonterminal for this frame.") + (rule :initarg :rule + :type number + :documentation + "The index into NONTERM's rule list. 0 based.") + (match :initarg :match + :type number + :documentation + "The index into NONTERM's RULE's match. 0 based..") + (collection :initarg :collection + :type list + :documentation + "List of things matched so far.") + (lextoken :initarg :lextoken + :type list + :documentation + "A Token created by `semantic-lex-token'. +This is the lexical token being matched by the parser.") + ) + "Debugger frame representation for the bovinator.") + +(defun semantic-bovine-debug-create-frame (nonterm rule match collection + lextoken) + "Create one bovine frame. +NONTERM is the name of a rule we are currently parsing. +RULE is the index into the list of rules in NONTERM. +MATCH is the index into the list of matches in RULE. +For example: + this: that + | other thing + | here + ; +The NONTERM is THIS. +The RULE is for \"thing\" is 1. +The MATCH for \"thing\" is 1. +COLLECTION is a list of `things' that have been matched so far. +LEXTOKEN, is a token returned by the lexer which is being matched." + (let ((frame (semantic-bovine-debug-frame "frame" + :nonterm nonterm + :rule rule + :match match + :collection collection + :lextoken lextoken))) + (semantic-debug-set-frame semantic-debug-current-interface + frame) + frame)) + +(defmethod semantic-debug-frame-highlight ((frame semantic-debug-frame)) + "Highlight one parser frame." + (let* ((nonterm (oref frame nonterm)) + (pb (oref semantic-debug-current-interface parser-buffer)) + (start (semantic-brute-find-tag-by-class 'start pb)) + ) + ;; Make sure we get a good rule name, and that it is a string + (if (and (eq nonterm 'bovine-toplevel) start) + (setq nonterm (semantic-tag-name (car start))) + (setq nonterm (symbol-name nonterm))) + + (semantic-debug-highlight-rule semantic-debug-current-interface + nonterm + (oref frame rule) + (oref frame match)) + (semantic-debug-highlight-lexical-token semantic-debug-current-interface + (oref frame lextoken)) + )) + +(defmethod semantic-debug-frame-info ((frame semantic-debug-frame)) + "Display info about this one parser frame." + (message "%S" (oref frame collection)) + ) + +;;; Lisp error thrown frame. +;; +(defclass semantic-bovine-debug-error-frame (semantic-debug-frame) + ((condition :initarg :condition + :documentation + "An error condition caught in an action.") + ) + "Debugger frame representaion of a lisp error thrown during parsing.") + +(defun semantic-create-bovine-debug-error-frame (condition) + "Create an error frame for bovine debugger. +Argument CONDITION is the thrown error condition." + (let ((frame (semantic-bovine-debug-error-frame "frame" + :condition condition))) + (semantic-debug-set-frame semantic-debug-current-interface + frame) + frame)) + +(defmethod semantic-debug-frame-highlight ((frame semantic-bovine-debug-error-frame)) + "Highlight a frame from an action." + ;; How do I get the location of the action in the source buffer? + ) + +(defmethod semantic-debug-frame-info ((frame semantic-bovine-debug-error-frame)) + "Display info about the error thrown." + (message "Error: %S" (oref frame condition))) + +;;; Parser support for the debugger +;; +(defclass semantic-bovine-debug-parser (semantic-debug-parser) + ( + ) + "Represents a parser and its state.") + + +(provide 'semantic/bovine/debug) + +;;; semantic/bovine/debug.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/bovine/el.el Sat Sep 05 20:47:41 2009 +0000 @@ -0,0 +1,966 @@ +;;; semantic/bovine/el.el --- Semantic details for Emacs Lisp + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, +;;; 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Use the Semantic Bovinator for Emacs Lisp + +(require 'semantic) +(require 'semantic/bovine) +(require 'find-func) + +(require 'semantic/ctxt) +(require 'semantic/format) +(require 'thingatpt) + +;;; 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-desymbolify-args (arglist) + "Convert symbols to strings for ARGLIST." + (let ((in (semantic-elisp-desymbolify arglist)) + (out nil)) + (dolist (T in) + (when (not (string-match "^&" T)) + (push T out))) + (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)) + (numberp (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-no-properties 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-args (nth 2 form)) + :user-visible-flag (eq (car-safe (nth 4 form)) 'interactive) + :documentation (semantic-elisp-do-doc (nth 3 form)) + :overloadable (or (eq (car form) 'define-overload) + (eq (car form) 'define-overloadable-function)) + )) + defun + defun* + defsubst + defmacro + define-overload ;; @todo - remove after cleaning up semantic. + define-overloadable-function + ) + +(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 + ) + +(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)) + "face" + (nth 2 form) + :user-visible-flag (and doc + (> (length doc) 0) + (= (aref doc 0) ?*)) + :documentation (semantic-elisp-do-doc doc) + ))) + defface + ) + + +(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)) + "image" + (nth 2 form) + :user-visible-flag (and doc + (> (length doc) 0) + (= (aref doc 0) ?*)) + :documentation (semantic-elisp-do-doc doc) + ))) + defimage + defezimage + ) + + +(semantic-elisp-setup-form-parser + (lambda (form start end) + (let ((doc (semantic-elisp-form-to-doc-string (nth 3 form)))) + (semantic-tag + (symbol-name (nth 1 form)) + 'customgroup + :value (nth 2 form) + :user-visible-flag t + :documentation (semantic-elisp-do-doc doc) + ))) + defgroup + ) + + +(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-args (cdr args))) + (semantic-elisp-desymbolify-args (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." + (if (fboundp 'find-library-name) + (condition-case nil + ;; Try an Emacs 22 fcn. This throws errors. + (find-library-name (semantic-tag-name tag)) + (error + (message "semantic: connot find source file %s" + (semantic-tag-name tag)))) + ;; No handy function available. (Older Emacsen) + (let* ((lib (locate-library (semantic-tag-name tag))) + (name (if lib (file-name-sans-extension lib) nil)) + (nameel (concat name ".el"))) + (cond + ((and name (file-exists-p nameel)) nameel) + ((and name (file-exists-p (concat name ".el.gz"))) + ;; This is the linux distro case. + (concat name ".el.gz")) + ;; source file does not exists + (name + (message "semantic: cannot find source file %s" (concat name ".el"))) + (t + nil))))) + +;;; DOC Strings +;; +(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@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-with-position-p 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))))) + +;;; Tag Features +;; +(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-insert-foreign-tag + emacs-lisp-mode (tag) + "Insert TAG 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-ctxt-current-function emacs-lisp-mode + (&optional point same-as-symbol-return) + "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))) + ;; Go up and try again. + same-as-symbol-return + ;; We are ok, so get it. + (list fun)) + )) + ))) + + +(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-emacs-lisp-mode + (point) (list t)))) + (cond + ((eq fn t) + nil) + ((member fn '("let" "let*" "with-slots")) + ;; Snarf variables + (up-list -1) + (forward-char 1) + (forward-symbol 1) + (skip-chars-forward "* \t\n") + (let ((varlst (read (buffer-substring-no-properties + (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))) + )) + ((string= fn "lambda") + ;; Snart args... + (up-list -1) + (forward-char 1) + (forward-word 1) + (skip-chars-forward "* \t\n") + (let ((arglst (read (buffer-substring-no-properties + (point) + (save-excursion + (forward-sexp 1) + (point)))))) + (while arglst + (let* ((name (car arglst))) + (when (/= ?& (aref (symbol-name name) 0)) + (setq vars (cons (semantic-tag-new-variable + (symbol-name name) + nil nil) + vars)))) + (setq arglst (cdr arglst))) + )) + ) + (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-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))) + )) + +;;; Formatting +;; +(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)) + ) + (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)) + ) + (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)) + +;;; IA Commands +;; +(define-mode-local-override semantic-ia-insert-tag + emacs-lisp-mode (tag) + "Insert TAG into the current buffer based on completion." + ;; This function by David <de_bb@...> is a tweaked version of the original. + (insert (semantic-tag-name tag)) + (let ((tt (semantic-tag-class tag)) + (args (semantic-tag-function-arguments tag))) + (cond ((eq tt 'function) + (if args + (insert " ") + (insert ")"))) + (t nil)))) + +;;; Lexical features and setup +;; +(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) + +(defvar-mode-local emacs-lisp-mode semantic-stickyfunc-sticky-classes + '(function type variable) + "Add variables. +ELisp variables can be pretty long, so track this one too.") + +(define-child-mode lisp-mode emacs-lisp-mode + "Make `lisp-mode' inherits mode local behavior from `emacs-lisp-mode'.") + +(defun semantic-default-elisp-setup () + "Setup hook function for Emacs Lisp files and Semantic." + ) + +(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) +;; +(add-hook 'lisp-mode-hook 'semantic-default-elisp-setup) + +(eval-after-load "semanticdb" + '(require 'semanticdb-el) + ) + +(provide 'semantic/bovine/el) + +;;; semantic/bovine/el.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/bovine/gcc.el Sat Sep 05 20:47:41 2009 +0000 @@ -0,0 +1,319 @@ +;;; semantic/bovine/gcc.el --- gcc querying special code for the C parser + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; GCC stores things in special places. These functions will query +;; GCC, and set up the preprocessor and include paths. + +(require 'semantic/dep) + +(declare-function semantic-c-reset-preprocessor-symbol-map + "semantic/bovine/gcc") + +;;; Code: + +(defun semantic-gcc-query (gcc-cmd &rest gcc-options) + "Return program output to both standard output and standard error. +GCC-CMD is the program to execute and GCC-OPTIONS are the options +to give to the program." + ;; $ gcc -v + ;; + (let ((buff (get-buffer-create " *gcc-query*")) + (old-lc-messages (getenv "LC_ALL"))) + (save-excursion + (set-buffer buff) + (erase-buffer) + (setenv "LC_ALL" "C") + (condition-case nil + (apply 'call-process gcc-cmd nil (cons buff t) nil gcc-options) + (error ;; Some bogus directory for the first time perhaps? + (let ((default-directory (expand-file-name "~/"))) + (condition-case nil + (apply 'call-process gcc-cmd nil (cons buff t) nil gcc-options) + (error ;; gcc doesn't exist??? + nil))))) + (setenv "LC_ALL" old-lc-messages) + (prog1 + (buffer-string) + (kill-buffer buff) + ) + ))) + +;;(semantic-gcc-get-include-paths "c") +;;(semantic-gcc-get-include-paths "c++") +(defun semantic-gcc-get-include-paths (lang) + "Return include paths as gcc use them for language LANG." + (let* ((gcc-cmd (cond + ((string= lang "c") "gcc") + ((string= lang "c++") "c++") + (t (if (stringp lang) + (error "Unknown lang: %s" lang) + (error "LANG=%S, should be a string" lang))))) + (gcc-output (semantic-gcc-query gcc-cmd "-v" "-E" "-x" lang null-device)) + (lines (split-string gcc-output "\n")) + (include-marks 0) + (inc-mark "#include ") + (inc-mark-len (length "#include ")) + inc-path) + ;;(message "gcc-output=%s" gcc-output) + (dolist (line lines) + (when (> (length line) 1) + (if (= 0 include-marks) + (when (and (> (length line) inc-mark-len) + (string= inc-mark (substring line 0 inc-mark-len))) + (setq include-marks (1+ include-marks))) + (let ((chars (append line nil))) + (when (= 32 (nth 0 chars)) + (let ((path (substring line 1))) + (when (file-accessible-directory-p path) + (when (if (memq system-type '(windows-nt)) + (/= ?/ (nth 1 chars)) + (= ?/ (nth 1 chars))) + (add-to-list 'inc-path + (expand-file-name (substring line 1)) + t))))))))) + inc-path)) + + +(defun semantic-cpp-defs (str) + "Convert CPP output STR into a list of cons cells with defines for C++." + (let ((lines (split-string str "\n")) + (lst nil)) + (dolist (L lines) + (let ((dat (split-string L))) + (when (= (length dat) 3) + (add-to-list 'lst (cons (nth 1 dat) (nth 2 dat)))))) + lst)) + +(defun semantic-gcc-fields (str) + "Convert GCC output STR into an alist of fields." + (let ((fields nil) + (lines (split-string str "\n")) + ) + (dolist (L lines) + ;; For any line, what do we do with it? + (cond ((or (string-match "Configured with\\(:\\)" L) + (string-match "\\(:\\)\\s-*[^ ]*configure " L)) + (let* ((parts (substring L (match-end 1))) + (opts (split-string parts " " t)) + ) + (dolist (O (cdr opts)) + (let* ((data (split-string O "=")) + (sym (intern (car data))) + (val (car (cdr data)))) + (push (cons sym val) fields) + )) + )) + ((string-match "gcc[ -][vV]ersion" L) + (let* ((vline (substring L (match-end 0))) + (parts (split-string vline " "))) + (push (cons 'version (nth 1 parts)) fields))) + ((string-match "Target: " L) + (let ((parts (split-string L " "))) + (push (cons 'target (nth 1 parts)) fields))) + )) + fields)) + +(defvar semantic-gcc-setup-data nil + "The GCC setup data. +This is setup by `semantic-gcc-setup'. +This is an alist, and should include keys of: + 'version - The version of gcc + '--host - The host symbol. (Used in include directories) + '--prefix - Where GCC was installed. +It should also include other symbols GCC was compiled with.") + +(defun semantic-gcc-setup () + "Setup Semantic C/C++ parsing based on GCC output." + (interactive) + (let* ((fields (or semantic-gcc-setup-data + (semantic-gcc-fields (semantic-gcc-query "gcc" "-v")))) + (defines (semantic-cpp-defs (semantic-gcc-query "cpp" "-E" "-dM" "-x" "c++" null-device))) + (ver (cdr (assoc 'version fields))) + (host (or (cdr (assoc 'target fields)) + (cdr (assoc '--target fields)) + (cdr (assoc '--host fields)))) + (prefix (cdr (assoc '--prefix fields))) + ;; gcc output supplied paths + (c-include-path (semantic-gcc-get-include-paths "c")) + (c++-include-path (semantic-gcc-get-include-paths "c++"))) + ;; Remember so we don't have to call GCC twice. + (setq semantic-gcc-setup-data fields) + (unless c-include-path + ;; Fallback to guesses + (let* ( ;; gcc include dirs + (gcc-exe (locate-file "gcc" exec-path exec-suffixes 'executable)) + (gcc-root (expand-file-name ".." (file-name-directory gcc-exe))) + (gcc-include (expand-file-name "include" gcc-root)) + (gcc-include-c++ (expand-file-name "c++" gcc-include)) + (gcc-include-c++-ver (expand-file-name ver gcc-include-c++)) + (gcc-include-c++-ver-host (expand-file-name host gcc-include-c++-ver))) + (setq c-include-path + (remove-if-not 'file-accessible-directory-p + (list "/usr/include" gcc-include))) + (setq c++-include-path + (remove-if-not 'file-accessible-directory-p + (list "/usr/include" + gcc-include + gcc-include-c++ + gcc-include-c++-ver + gcc-include-c++-ver-host))))) + + ;;; Fix-me: I think this part might have been a misunderstanding, but I am not sure. + ;; If this option is specified, try it both with and without prefix, and with and without host + ;; (if (assoc '--with-gxx-include-dir fields) + ;; (let ((gxx-include-dir (cdr (assoc '--with-gxx-include-dir fields)))) + ;; (nconc try-paths (list gxx-include-dir + ;; (concat prefix gxx-include-dir) + ;; (concat gxx-include-dir "/" host) + ;; (concat prefix gxx-include-dir "/" host))))) + + ;; Now setup include paths etc + (dolist (D (semantic-gcc-get-include-paths "c")) + (semantic-add-system-include D 'c-mode)) + (dolist (D (semantic-gcc-get-include-paths "c++")) + (semantic-add-system-include D 'c++-mode) + (let ((cppconfig (concat D "/bits/c++config.h"))) + ;; Presumably there will be only one of these files in the try-paths list... + (when (file-readable-p cppconfig) + ;; Add it to the symbol file + (if (boundp 'semantic-lex-c-preprocessor-symbol-file) + ;; Add to the core macro header list + (add-to-list 'semantic-lex-c-preprocessor-symbol-file cppconfig) + ;; Setup the core macro header + (setq semantic-lex-c-preprocessor-symbol-file (list cppconfig))) + ))) + (if (not (boundp 'semantic-lex-c-preprocessor-symbol-map)) + (setq semantic-lex-c-preprocessor-symbol-map nil)) + (dolist (D defines) + (add-to-list 'semantic-lex-c-preprocessor-symbol-map D)) + (when (featurep 'semantic/bovine/c) + (semantic-c-reset-preprocessor-symbol-map)) + nil)) + +;;; TESTING +;; +;; Example output of "gcc -v" +(defvar semantic-gcc-test-strings + '(;; My old box: + "Reading specs from /usr/lib/gcc-lib/i386-redhat-linux/3.2.2/specs +Configured with: ../configure --prefix=/usr --mandir=/usr/share/man --infodir=/usr/share/info --enable-shared --enable-threads=posix --disable-checking --with-system-zlib --enable-__cxa_atexit --host=i386-redhat-linux +Thread model: posix +gcc version 3.2.2 20030222 (Red Hat Linux 3.2.2-5)" + ;; Alex Ott: + "Using built-in specs. +Target: i486-linux-gnu +Configured with: ../src/configure -v --with-pkgversion='Ubuntu 4.3.1-9ubuntu1' --with-bugurl=file:///usr/share/doc/gcc-4.3/README.Bugs --enable-languages=c,c++,fortran,objc,obj-c++ --prefix=/usr --enable-shared --with-system-zlib --libexecdir=/usr/lib --without-included-gettext --enable-threads=posix --enable-nls --with-gxx-include-dir=/usr/include/c++/4.3 --program-suffix=-4.3 --enable-clocale=gnu --enable-libstdcxx-debug --enable-objc-gc --enable-mpfr --enable-targets=all --enable-checking=release --build=i486-linux-gnu --host=i486-linux-gnu --target=i486-linux-gnu +Thread model: posix +gcc version 4.3.1 (Ubuntu 4.3.1-9ubuntu1)" + ;; My debian box: + "Using built-in specs. +Target: x86_64-unknown-linux-gnu +Configured with: ../../../sources/gcc/configure --prefix=/usr/local/glibc-2.3.6/x86_64/apps/gcc-4.2.3 --with-gmp=/usr/local/gcc/gmp --with-mpfr=/usr/local/gcc/mpfr --enable-languages=c,c++,fortran --with-as=/usr/local/glibc-2.3.6/x86_64/apps/gcc-4.2.3/bin/as --with-ld=/usr/local/glibc-2.3.6/x86_64/apps/gcc-4.2.3/bin/ld --disable-multilib +Thread model: posix +gcc version 4.2.3" + ;; My mac: + "Using built-in specs. +Target: i686-apple-darwin8 +Configured with: /private/var/tmp/gcc/gcc-5341.obj~1/src/configure --disable-checking -enable-werror --prefix=/usr --mandir=/share/man --enable-languages=c,objc,c++,obj-c++ --program-transform-name=/^[cg][^.-]*$/s/$/-4.0/ --with-gxx-include-dir=/include/c++/4.0.0 --with-slibdir=/usr/lib --build=powerpc-apple-darwin8 --with-arch=pentium-m --with-tune=prescott --program-prefix= --host=i686-apple-darwin8 --target=i686-apple-darwin8 +Thread model: posix +gcc version 4.0.1 (Apple Computer, Inc. build 5341)" + ;; Ubuntu Intrepid + "Using built-in specs. +Target: x86_64-linux-gnu +Configured with: ../src/configure -v --with-pkgversion='Ubuntu 4.3.2-1ubuntu12' --with-bugurl=file:///usr/share/doc/gcc-4.3/README.Bugs --enable-languages=c,c++,fortran,objc,obj-c++ --prefix=/usr --enable-shared --with-system-zlib --libexecdir=/usr/lib --without-included-gettext --enable-threads=posix --enable-nls --with-gxx-include-dir=/usr/include/c++/4.3 --program-suffix=-4.3 --enable-clocale=gnu --enable-libstdcxx-debug --enable-objc-gc --enable-mpfr --enable-checking=release --build=x86_64-linux-gnu --host=x86_64-linux-gnu --target=x86_64-linux-gnu +Thread model: posix +gcc version 4.3.2 (Ubuntu 4.3.2-1ubuntu12)" + ;; Red Hat EL4 + "Reading specs from /usr/lib/gcc/x86_64-redhat-linux/3.4.6/specs +Configured with: ../configure --prefix=/usr --mandir=/usr/share/man --infodir=/usr/share/info --enable-shared --enable-threads=posix --disable-checking --with-system-zlib --enable-__cxa_atexit --disable-libunwind-exceptions --enable-java-awt=gtk --host=x86_64-redhat-linux +Thread model: posix +gcc version 3.4.6 20060404 (Red Hat 3.4.6-10)" + ;; Red Hat EL5 + "Using built-in specs. +Target: x86_64-redhat-linux +Configured with: ../configure --prefix=/usr --mandir=/usr/share/man --infodir=/usr/share/info --enable-shared --enable-threads=posix --enable-checking=release --with-system-zlib --enable-__cxa_atexit --disable-libunwind-exceptions --enable-libgcj-multifile --enable-languages=c,c++,objc,obj-c++,java,fortran,ada --enable-java-awt=gtk --disable-dssi --enable-plugin --with-java-home=/usr/lib/jvm/java-1.4.2-gcj-1.4.2.0/jre --with-cpu=generic --host=x86_64-redhat-linux +Thread model: posix +gcc version 4.1.2 20080704 (Red Hat 4.1.2-44)" + ;; David Engster's german gcc on ubuntu 4.3 + "Es werden eingebaute Spezifikationen verwendet. +Ziel: i486-linux-gnu +Konfiguriert mit: ../src/configure -v --with-pkgversion='Ubuntu 4.3.2-1ubuntu12' --with-bugurl=file:///usr/share/doc/gcc-4.3/README.Bugs --enable-languages=c,c++,fortran,objc,obj-c++ --prefix=/usr --enable-shared --with-system-zlib --libexecdir=/usr/lib --without-included-gettext --enable-threads=posix --enable-nls --with-gxx-include-dir=/usr/include/c++/4.3 --program-suffix=-4.3 --enable-clocale=gnu --enable-libstdcxx-debug --enable-objc-gc --enable-mpfr --enable-targets=all --enable-checking=release --build=i486-linux-gnu --host=i486-linux-gnu --target=i486-linux-gnu +Thread-Modell: posix +gcc-Version 4.3.2 (Ubuntu 4.3.2-1ubuntu12)" + ;; Damien Deville bsd + "Using built-in specs. +Target: i386-undermydesk-freebsd +Configured with: FreeBSD/i386 system compiler +Thread model: posix +gcc version 4.2.1 20070719 [FreeBSD]" + ) + "A bunch of sample gcc -v outputs from different machines.") + +(defvar semantic-gcc-test-strings-fail + '(;; A really old solaris box I found + "Reading specs from /usr/local/gcc-2.95.2/lib/gcc-lib/sparc-sun-solaris2.6/2.95.2/specs +gcc version 2.95.2 19991024 (release)" + ) + "A bunch of sample gcc -v outputs that fail to provide the info we want.") + +(defun semantic-gcc-test-output-parser () + "Test the output parser against some collected strings." + (interactive) + (let ((fail nil)) + (dolist (S semantic-gcc-test-strings) + (let* ((fields (semantic-gcc-fields S)) + (v (cdr (assoc 'version fields))) + (h (or (cdr (assoc 'target fields)) + (cdr (assoc '--target fields)) + (cdr (assoc '--host fields)))) + (p (cdr (assoc '--prefix fields))) + ) + ;; No longer test for prefixes. + (when (not (and v h)) + (let ((strs (split-string S "\n"))) + (message "Test failed on %S\nV H P:\n%S %S %S" (car strs) v h p)) + (setq fail t)) + )) + (dolist (S semantic-gcc-test-strings-fail) + (let* ((fields (semantic-gcc-fields S)) + (v (cdr (assoc 'version fields))) + (h (or (cdr (assoc '--host fields)) + (cdr (assoc 'target fields)))) + (p (cdr (assoc '--prefix fields))) + ) + (when (and v h p) + (message "Negative test failed on %S" S) + (setq fail t)) + )) + (if (not fail) (message "Tests passed.")) + )) + +(defun semantic-gcc-test-output-parser-this-machine () + "Test the output parser against the machine currently running Emacs." + (interactive) + (let ((semantic-gcc-test-strings (list (semantic-gcc-query "gcc" "-v")))) + (semantic-gcc-test-output-parser)) + ) + +(provide 'semantic/bovine/gcc) +;;; semantic/bovine/gcc.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/bovine/java.el Sat Sep 05 20:47:41 2009 +0000 @@ -0,0 +1,465 @@ +;;; semantic/bovine/java.el --- Semantic functions for Java + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, +;;; 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: David Ponce <david@dponce.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Common function for Java parsers. + +;;; History: +;; + +;;; Code: +(require 'semantic) +(require 'semantic/ctxt) +(require 'semantic/doc) +(require 'semantic/format) + +(eval-when-compile + (require 'semantic/find) + (require 'semantic/dep)) + + +;;; Lexical analysis +;; +(defconst semantic-java-number-regexp + (eval-when-compile + (concat "\\(" + "\\<[0-9]+[.][0-9]+\\([eE][-+]?[0-9]+\\)?[fFdD]?\\>" + "\\|" + "\\<[0-9]+[.][eE][-+]?[0-9]+[fFdD]?\\>" + "\\|" + "\\<[0-9]+[.][fFdD]\\>" + "\\|" + "\\<[0-9]+[.]" + "\\|" + "[.][0-9]+\\([eE][-+]?[0-9]+\\)?[fFdD]?\\>" + "\\|" + "\\<[0-9]+[eE][-+]?[0-9]+[fFdD]?\\>" + "\\|" + "\\<0[xX][0-9a-fA-F]+[lL]?\\>" + "\\|" + "\\<[0-9]+[lLfFdD]?\\>" + "\\)" + )) + "Lexer regexp to match Java number terminals. +Following is the specification of Java number literals. + +DECIMAL_LITERAL: + [1-9][0-9]* + ; +HEX_LITERAL: + 0[xX][0-9a-fA-F]+ + ; +OCTAL_LITERAL: + 0[0-7]* + ; +INTEGER_LITERAL: + <DECIMAL_LITERAL>[lL]? + | <HEX_LITERAL>[lL]? + | <OCTAL_LITERAL>[lL]? + ; +EXPONENT: + [eE][+-]?[09]+ + ; +FLOATING_POINT_LITERAL: + [0-9]+[.][0-9]*<EXPONENT>?[fFdD]? + | [.][0-9]+<EXPONENT>?[fFdD]? + | [0-9]+<EXPONENT>[fFdD]? + | [0-9]+<EXPONENT>?[fFdD] + ;") + +;;; Parsing +;; +(defsubst semantic-java-dim (id) + "Split ID string into a pair (NAME . DIM). +NAME is ID without trailing brackets: \"[]\". +DIM is the dimension of NAME deduced from the number of trailing +brackets, or 0 if there is no trailing brackets." + (let ((dim (string-match "\\(\\[]\\)+\\'" id))) + (if dim + (cons (substring id 0 dim) + (/ (length (match-string 0 id)) 2)) + (cons id 0)))) + +(defsubst semantic-java-type (tag) + "Return the type of TAG, taking care of array notation." + (let ((type (semantic-tag-type tag)) + (dim (semantic-tag-get-attribute tag :dereference))) + (when dim + (while (> dim 0) + (setq type (concat type "[]") + dim (1- dim)))) + type)) + +(defun semantic-java-expand-tag (tag) + "Expand compound declarations found in TAG into separate tags. +TAG contains compound declarations when its class is `variable', and +its name is a list of elements (NAME START . END), where NAME is a +compound variable name, and START/END are the bounds of the +corresponding compound declaration." + (let* ((class (semantic-tag-class tag)) + (elts (semantic-tag-name tag)) + dim type dim0 elt clone start end xpand) + (cond + ((and (eq class 'function) + (> (cdr (setq dim (semantic-java-dim elts))) 0)) + (setq clone (semantic-tag-clone tag (car dim)) + xpand (cons clone xpand)) + (semantic-tag-put-attribute clone :dereference (cdr dim))) + ((eq class 'variable) + (or (consp elts) (setq elts (list (list elts)))) + (setq dim (semantic-java-dim (semantic-tag-get-attribute tag :type)) + type (car dim) + dim0 (cdr dim)) + (while elts + ;; For each compound element, clone the initial tag with the + ;; name and bounds of the compound variable declaration. + (setq elt (car elts) + elts (cdr elts) + start (if elts (cadr elt) (semantic-tag-start tag)) + end (if xpand (cddr elt) (semantic-tag-end tag)) + dim (semantic-java-dim (car elt)) + clone (semantic-tag-clone tag (car dim)) + xpand (cons clone xpand)) + (semantic-tag-put-attribute clone :type type) + (semantic-tag-put-attribute clone :dereference (+ dim0 (cdr dim))) + (semantic-tag-set-bounds clone start end))) + ) + xpand)) + +;;; Environment +;; +(defcustom-mode-local-semantic-dependency-system-include-path + java-mode semantic-java-dependency-system-include-path + ;; @todo - Use JDEE to get at the include path, or something else? + nil + "The system include path used by Java langauge.") + +;; Local context +;; +(define-mode-local-override semantic-ctxt-scoped-types + java-mode (&optional point) + "Return a list of type names currently in scope at POINT." + (mapcar 'semantic-tag-name + (semantic-find-tags-by-class + 'type (semantic-find-tag-by-overlay point)))) + +;; Prototype handler +;; +(defun semantic-java-prototype-function (tag &optional parent color) + "Return a function (method) prototype for TAG. +Optional argument PARENT is a parent (containing) item. +Optional argument COLOR indicates that color should be mixed in. +See also `semantic-format-prototype-tag'." + (let ((name (semantic-tag-name tag)) + (type (semantic-java-type tag)) + (tmpl (semantic-tag-get-attribute tag :template-specifier)) + (args (semantic-tag-function-arguments tag)) + (argp "") + arg argt) + (while args + (setq arg (car args) + args (cdr args)) + (if (semantic-tag-p arg) + (setq argt (if color + (semantic--format-colorize-text + (semantic-java-type arg) 'type) + (semantic-java-type arg)) + argp (concat argp argt (if args "," ""))))) + (when color + (when type + (setq type (semantic--format-colorize-text type 'type))) + (setq name (semantic--format-colorize-text name 'function))) + (concat (or tmpl "") (if tmpl " " "") + (or type "") (if type " " "") + name "(" argp ")"))) + +(defun semantic-java-prototype-variable (tag &optional parent color) + "Return a variable (field) prototype for TAG. +Optional argument PARENT is a parent (containing) item. +Optional argument COLOR indicates that color should be mixed in. +See also `semantic-format-prototype-tag'." + (let ((name (semantic-tag-name tag)) + (type (semantic-java-type tag))) + (concat (if color + (semantic--format-colorize-text type 'type) + type) + " " + (if color + (semantic--format-colorize-text name 'variable) + name)))) + +(defun semantic-java-prototype-type (tag &optional parent color) + "Return a type (class/interface) prototype for TAG. +Optional argument PARENT is a parent (containing) item. +Optional argument COLOR indicates that color should be mixed in. +See also `semantic-format-prototype-tag'." + (let ((name (semantic-tag-name tag)) + (type (semantic-tag-type tag)) + (tmpl (semantic-tag-get-attribute tag :template-specifier))) + (concat type " " + (if color + (semantic--format-colorize-text name 'type) + name) + (or tmpl "")))) + +(define-mode-local-override semantic-format-prototype-tag + java-mode (tag &optional parent color) + "Return a prototype for TOKEN. +Optional argument PARENT is a parent (containing) item. +Optional argument COLOR indicates that color should be mixed in." + (let ((f (intern-soft (format "semantic-java-prototype-%s" + (semantic-tag-class tag))))) + (funcall (if (fboundp f) + f + 'semantic-format-tag-prototype-default) + tag parent color))) + +(semantic-alias-obsolete 'semantic-java-prototype-nonterminal + 'semantic-format-prototype-tag-java-mode) + +;; Include Tag Name +;; + +;; Thanks Bruce Stephens +(define-mode-local-override semantic-tag-include-filename java-mode (tag) + "Return a suitable path for (some) Java imports" + (let ((name (semantic-tag-name tag))) + (concat (mapconcat 'identity (split-string name "\\.") "/") ".java"))) + + +;; Documentation handler +;; +(defsubst semantic-java-skip-spaces-backward () + "Move point backward, skipping Java whitespaces." + (skip-chars-backward " \n\r\t")) + +(defsubst semantic-java-skip-spaces-forward () + "Move point forward, skipping Java whitespaces." + (skip-chars-forward " \n\r\t")) + +(define-mode-local-override semantic-documentation-for-tag + java-mode (&optional tag nosnarf) + "Find documentation from TAG and return it as a clean string. +Java have documentation set in a comment preceeding TAG's definition. +Attempt to strip out comment syntactic sugar, unless optional argument +NOSNARF is non-nil. +If NOSNARF is 'lex, then return the semantic lex token." + (when (or tag (setq tag (semantic-current-tag))) + (with-current-buffer (semantic-tag-buffer tag) + (save-excursion + ;; Move the point at token start + (goto-char (semantic-tag-start tag)) + (semantic-java-skip-spaces-forward) + ;; If the point already at "/**" (this occurs after a doc fix) + (if (looking-at "/\\*\\*") + nil + ;; Skip previous spaces + (semantic-java-skip-spaces-backward) + ;; Ensure point is after "*/" (javadoc block comment end) + (condition-case nil + (backward-char 2) + (error nil)) + (when (looking-at "\\*/") + ;; Move the point backward across the comment + (forward-char 2) ; return just after "*/" + (forward-comment -1) ; to skip the entire block + )) + ;; Verify the point is at "/**" (javadoc block comment start) + (if (looking-at "/\\*\\*") + (let ((p (point)) + (c (semantic-doc-snarf-comment-for-tag 'lex))) + (when c + ;; Verify that the token just following the doc + ;; comment is the current one! + (goto-char (semantic-lex-token-end c)) + (semantic-java-skip-spaces-forward) + (when (eq tag (semantic-current-tag)) + (goto-char p) + (semantic-doc-snarf-comment-for-tag nosnarf))))) + )))) + +;;; Javadoc facilities +;; + +;; Javadoc elements +;; +(defvar semantic-java-doc-line-tags nil + "Valid javadoc line tags. +Ordered following Sun's Tag Convention at +<http://java.sun.com/products/jdk/javadoc/writingdoccomments/index.html>") + +(defvar semantic-java-doc-with-name-tags nil + "Javadoc tags which have a name.") + +(defvar semantic-java-doc-with-ref-tags nil + "Javadoc tags which have a reference.") + +;; Optional javadoc tags by classes of semantic tag +;; +(defvar semantic-java-doc-extra-type-tags nil + "Optional tags used in class/interface documentation. +Ordered following Sun's Tag Convention.") + +(defvar semantic-java-doc-extra-function-tags nil + "Optional tags used in method/constructor documentation. +Ordered following Sun's Tag Convention.") + +(defvar semantic-java-doc-extra-variable-tags nil + "Optional tags used in field documentation. +Ordered following Sun's Tag Convention.") + +;; All javadoc tags by classes of semantic tag +;; +(defvar semantic-java-doc-type-tags nil + "Tags allowed in class/interface documentation. +Ordered following Sun's Tag Convention.") + +(defvar semantic-java-doc-function-tags nil + "Tags allowed in method/constructor documentation. +Ordered following Sun's Tag Convention.") + +(defvar semantic-java-doc-variable-tags nil + "Tags allowed in field documentation. +Ordered following Sun's Tag Convention.") + +;; Access to Javadoc elements +;; +(defmacro semantic-java-doc-tag (name) + "Return doc tag from NAME. +That is @NAME." + `(concat "@" ,name)) + +(defsubst semantic-java-doc-tag-name (tag) + "Return name of the doc TAG symbol. +That is TAG `symbol-name' without the leading '@'." + (substring (symbol-name tag) 1)) + +(defun semantic-java-doc-keyword-before-p (k1 k2) + "Return non-nil if javadoc keyword K1 is before K2." + (let* ((t1 (semantic-java-doc-tag k1)) + (t2 (semantic-java-doc-tag k2)) + (seq1 (and (semantic-lex-keyword-p t1) + (plist-get (semantic-lex-keyword-get t1 'javadoc) + 'seq))) + (seq2 (and (semantic-lex-keyword-p t2) + (plist-get (semantic-lex-keyword-get t2 'javadoc) + 'seq)))) + (if (and (numberp seq1) (numberp seq2)) + (<= seq1 seq2) + ;; Unknown tags (probably custom ones) are always after official + ;; ones and are not themselves ordered. + (or (numberp seq1) + (and (not seq1) (not seq2)))))) + +(defun semantic-java-doc-keywords-map (fun &optional property) + "Run function FUN for each javadoc keyword. +Return the list of FUN results. If optional PROPERTY is non nil only +call FUN for javadoc keyword which have a value for PROPERTY. FUN +receives two arguments: the javadoc keyword and its associated +'javadoc property list. It can return any value. Nil values are +removed from the result list." + (delq nil + (mapcar + #'(lambda (k) + (let* ((tag (semantic-java-doc-tag k)) + (plist (semantic-lex-keyword-get tag 'javadoc))) + (if (or (not property) (plist-get plist property)) + (funcall fun k plist)))) + semantic-java-doc-line-tags))) + + +;;; Mode setup +;; + +(defun semantic-java-doc-setup () + "Lazy initialization of javadoc elements." + (or semantic-java-doc-line-tags + (setq semantic-java-doc-line-tags + (sort (mapcar #'semantic-java-doc-tag-name + (semantic-lex-keywords 'javadoc)) + #'semantic-java-doc-keyword-before-p))) + + (or semantic-java-doc-with-name-tags + (setq semantic-java-doc-with-name-tags + (semantic-java-doc-keywords-map + #'(lambda (k p) + k) + 'with-name))) + + (or semantic-java-doc-with-ref-tags + (setq semantic-java-doc-with-ref-tags + (semantic-java-doc-keywords-map + #'(lambda (k p) + k) + 'with-ref))) + + (or semantic-java-doc-extra-type-tags + (setq semantic-java-doc-extra-type-tags + (semantic-java-doc-keywords-map + #'(lambda (k p) + (if (memq 'type (plist-get p 'usage)) + k)) + 'opt))) + + (or semantic-java-doc-extra-function-tags + (setq semantic-java-doc-extra-function-tags + (semantic-java-doc-keywords-map + #'(lambda (k p) + (if (memq 'function (plist-get p 'usage)) + k)) + 'opt))) + + (or semantic-java-doc-extra-variable-tags + (setq semantic-java-doc-extra-variable-tags + (semantic-java-doc-keywords-map + #'(lambda (k p) + (if (memq 'variable (plist-get p 'usage)) + k)) + 'opt))) + + (or semantic-java-doc-type-tags + (setq semantic-java-doc-type-tags + (semantic-java-doc-keywords-map + #'(lambda (k p) + (if (memq 'type (plist-get p 'usage)) + k))))) + + (or semantic-java-doc-function-tags + (setq semantic-java-doc-function-tags + (semantic-java-doc-keywords-map + #'(lambda (k p) + (if (memq 'function (plist-get p 'usage)) + k))))) + + (or semantic-java-doc-variable-tags + (setq semantic-java-doc-variable-tags + (semantic-java-doc-keywords-map + #'(lambda (k p) + (if (memq 'variable (plist-get p 'usage)) + k))))) + + ) + +(provide 'semantic/bovine/java) + +;;; semantic/bovine/java.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/bovine/make-by.el Sat Sep 05 20:47:41 2009 +0000 @@ -0,0 +1,394 @@ +;;; semantic/bovine/make-by.el --- Generated parser support file + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2008 +;;; Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This file was generated from the grammar file +;; semantic/bovine/make.by in the CEDET repository. + +;;; Code: + +(eval-when-compile (require 'semantic/bovine)) + +;;; Prologue +;; + +;;; Declarations +;; +(defconst semantic-make-by--keyword-table + (semantic-lex-make-keyword-table + '(("if" . IF) + ("ifdef" . IFDEF) + ("ifndef" . IFNDEF) + ("ifeq" . IFEQ) + ("ifneq" . IFNEQ) + ("else" . ELSE) + ("endif" . ENDIF) + ("include" . INCLUDE)) + '(("include" summary "Macro: include filename1 filename2 ...") + ("ifneq" summary "Conditional: ifneq (expression) ... else ... endif") + ("ifeq" summary "Conditional: ifeq (expression) ... else ... endif") + ("ifndef" summary "Conditional: ifndef (expression) ... else ... endif") + ("ifdef" summary "Conditional: ifdef (expression) ... else ... endif") + ("endif" summary "Conditional: if (expression) ... else ... endif") + ("else" summary "Conditional: if (expression) ... else ... endif") + ("if" summary "Conditional: if (expression) ... else ... endif"))) + "Table of language keywords.") + +(defconst semantic-make-by--token-table + (semantic-lex-make-type-table + '(("punctuation" + (BACKSLASH . "\\`[\\]\\'") + (DOLLAR . "\\`[$]\\'") + (EQUAL . "\\`[=]\\'") + (PLUS . "\\`[+]\\'") + (COLON . "\\`[:]\\'"))) + 'nil) + "Table of lexical tokens.") + +(defconst semantic-make-by--parse-table + `( + (bovine-toplevel + (Makefile) + ) ;; end bovine-toplevel + + (Makefile + (bol + newline + ,(semantic-lambda + (list nil)) + ) + (bol + variable + ,(semantic-lambda + (nth 1 vals)) + ) + (bol + rule + ,(semantic-lambda + (nth 1 vals)) + ) + (bol + conditional + ,(semantic-lambda + (nth 1 vals)) + ) + (bol + include + ,(semantic-lambda + (nth 1 vals)) + ) + (whitespace + ,(semantic-lambda + (list nil)) + ) + (newline + ,(semantic-lambda + (list nil)) + ) + ) ;; end Makefile + + (variable + (symbol + opt-whitespace + equals + opt-whitespace + element-list + ,(semantic-lambda + (semantic-tag-new-variable + (nth 0 vals) nil + (nth 4 vals))) + ) + ) ;; end variable + + (rule + (targets + opt-whitespace + colons + opt-whitespace + element-list + commands + ,(semantic-lambda + (semantic-tag-new-function + (nth 0 vals) nil + (nth 4 vals))) + ) + ) ;; end rule + + (targets + (target + opt-whitespace + targets + ,(semantic-lambda + (list + (car + (nth 0 vals)) + (car + (nth 2 vals)))) + ) + (target + ,(semantic-lambda + (list + (car + (nth 0 vals)))) + ) + ) ;; end targets + + (target + (sub-target + target + ,(semantic-lambda + (list + (concat + (car + (nth 0 vals)) + (car + (nth 2 vals))))) + ) + (sub-target + ,(semantic-lambda + (list + (car + (nth 0 vals)))) + ) + ) ;; end target + + (sub-target + (symbol) + (string) + (varref) + ) ;; end sub-target + + (conditional + (IF + some-whitespace + symbol + newline + ,(semantic-lambda + (list nil)) + ) + (IFDEF + some-whitespace + symbol + newline + ,(semantic-lambda + (list nil)) + ) + (IFNDEF + some-whitespace + symbol + newline + ,(semantic-lambda + (list nil)) + ) + (IFEQ + some-whitespace + expression + newline + ,(semantic-lambda + (list nil)) + ) + (IFNEQ + some-whitespace + expression + newline + ,(semantic-lambda + (list nil)) + ) + (ELSE + newline + ,(semantic-lambda + (list nil)) + ) + (ENDIF + newline + ,(semantic-lambda + (list nil)) + ) + ) ;; end conditional + + (expression + (semantic-list) + ) ;; end expression + + (include + (INCLUDE + some-whitespace + element-list + ,(semantic-lambda + (semantic-tag-new-include + (nth 2 vals) nil)) + ) + ) ;; end include + + (equals + (punctuation + "\\`[:]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda) + ) + (punctuation + "\\`[+]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda) + ) + (punctuation + "\\`[=]\\'" + ,(semantic-lambda) + ) + ) ;; end equals + + (colons + (punctuation + "\\`[:]\\'" + punctuation + "\\`[:]\\'" + ,(semantic-lambda) + ) + (punctuation + "\\`[:]\\'" + ,(semantic-lambda) + ) + ) ;; end colons + + (element-list + (elements + newline + ,(semantic-lambda + (nth 0 vals)) + ) + ) ;; end element-list + + (elements + (element + some-whitespace + elements + ,(semantic-lambda + (nth 0 vals) + (nth 2 vals)) + ) + (element + ,(semantic-lambda + (nth 0 vals)) + ) + ( ;;EMPTY + ) + ) ;; end elements + + (element + (sub-element + element + ,(semantic-lambda + (list + (concat + (car + (nth 0 vals)) + (car + (nth 1 vals))))) + ) + ( ;;EMPTY + ) + ) ;; end element + + (sub-element + (symbol) + (string) + (punctuation) + (semantic-list + ,(semantic-lambda + (list + (buffer-substring-no-properties + (identity start) + (identity end)))) + ) + ) ;; end sub-element + + (varref + (punctuation + "\\`[$]\\'" + semantic-list + ,(semantic-lambda + (list + (buffer-substring-no-properties + (identity start) + (identity end)))) + ) + ) ;; end varref + + (commands + (bol + shell-command + newline + commands + ,(semantic-lambda + (list + (nth 0 vals)) + (nth 1 vals)) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end commands + + (opt-whitespace + (some-whitespace + ,(semantic-lambda + (list nil)) + ) + ( ;;EMPTY + ) + ) ;; end opt-whitespace + + (some-whitespace + (whitespace + some-whitespace + ,(semantic-lambda + (list nil)) + ) + (whitespace + ,(semantic-lambda + (list nil)) + ) + ) ;; end some-whitespace + ) + "Parser table.") + +(defun semantic-make-by--install-parser () + "Setup the Semantic Parser." + (setq semantic--parse-table semantic-make-by--parse-table + semantic-debug-parser-source "make.by" + semantic-debug-parser-class 'semantic-bovine-debug-parser + semantic-flex-keywords-obarray semantic-make-by--keyword-table + )) + + +;;; Analyzers +;; +(require 'semantic/lex) + + +;;; Epilogue +;; + +(provide 'semantic/bovine/make-by) + +;;; semantic/bovine/make-by.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/bovine/make.el Sat Sep 05 20:47:41 2009 +0000 @@ -0,0 +1,236 @@ +;;; semantic/bovine/make.el --- Makefile parsing rules. + +;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2008 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Use the Semantic Bovinator to parse Makefiles. +;; Concocted as an experiment for nonstandard languages. + +(require 'make-mode) + +(require 'semantic) +(require 'semantic/bovine/make-by) +(require 'semantic/analyze) +(require 'semantic/format) + +(eval-when-compile + (require 'semantic/dep)) + +;;; Code: +(define-lex-analyzer semantic-lex-make-backslash-no-newline + "Detect and create a beginning of line token (BOL)." + (and (looking-at "\\(\\\\\n\\s-*\\)") + ;; We have a \ at eol. Push it as whitespace, but pretend + ;; it never happened so we can skip the BOL tokenizer. + (semantic-lex-push-token (semantic-lex-token 'whitespace + (match-beginning 1) + (match-end 1))) + (goto-char (match-end 1)) + nil) ;; CONTINUE + ;; We want to skip BOL, so move to the next condition. + nil) + +(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-regex-analyzer semantic-lex-make-ignore-automake-conditional + "An automake conditional seems to really bog down the parser. +Ignore them." + "^@\\(\\w\\|\\s_\\)+@" + (setq semantic-lex-end-point (match-end 0))) + +(define-lex semantic-make-lexer + "Lexical analyzer for Makefiles." + semantic-lex-beginning-of-line + semantic-lex-make-ignore-automake-conditional + semantic-lex-make-command + semantic-lex-make-backslash-no-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) + ;(message "Expanding %S" name) + ;(goto-char (semantic-tag-start tag)) + ;(sit-for 0) + (if (and (consp name) + (memq (semantic-tag-class tag) '(function include)) + (> (length name) 1)) + (while name + (setq xpand (cons (semantic-tag-clone tag (car name)) xpand) + name (cdr name))) + ;; Else, only a single name. + (when (consp name) + (setcar tag (car name))) + (setq xpand (list tag))) + 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) + ))) + +(defcustom-mode-local-semantic-dependency-system-include-path + makefile-mode semantic-makefile-dependency-system-include-path + nil + "The system include path used by Makefiles langauge.") + +(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) + ) + +(add-hook 'makefile-mode-hook 'semantic-default-make-setup) + +(provide 'semantic/bovine/make) + +;;; semantic/bovine/make.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/bovine/scm-by.el Sat Sep 05 20:47:41 2009 +0000 @@ -0,0 +1,198 @@ +;;; semantic-scm-by.el --- Generated parser support file + +;; Copyright (C) 2001, 2003, 2009 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This file was generated from the grammar file +;; semantic/bovine/scm.by in the CEDET repository. + +;;; Code: + +(eval-when-compile (require 'semantic/bovine)) + +;;; Prologue +;; + +;;; Declarations +;; +(defconst semantic-scm-by--keyword-table + (semantic-lex-make-keyword-table + '(("define" . DEFINE) + ("define-module" . DEFINE-MODULE) + ("load" . LOAD)) + '(("load" summary "Function: (load \"filename\")") + ("define-module" summary "Function: (define-module (name arg1 ...)) ") + ("define" summary "Function: (define symbol expression)"))) + "Table of language keywords.") + +(defconst semantic-scm-by--token-table + (semantic-lex-make-type-table + '(("close-paren" + (CLOSEPAREN . ")")) + ("open-paren" + (OPENPAREN . "("))) + 'nil) + "Table of lexical tokens.") + +(defconst semantic-scm-by--parse-table + `( + (bovine-toplevel + (scheme) + ) ;; end bovine-toplevel + + (scheme + (semantic-list + ,(lambda (vals start end) + (semantic-bovinate-from-nonterminal + (car + (nth 0 vals)) + (cdr + (nth 0 vals)) + 'scheme-list)) + ) + ) ;; end scheme + + (scheme-list + (open-paren + "(" + scheme-in-list + close-paren + ")" + ,(semantic-lambda + (nth 1 vals)) + ) + ) ;; end scheme-list + + (scheme-in-list + (DEFINE + symbol + expression + ,(semantic-lambda + (semantic-tag-new-variable + (nth 1 vals) nil + (nth 2 vals))) + ) + (DEFINE + name-args + opt-doc + sequence + ,(semantic-lambda + (semantic-tag-new-function + (car + (nth 1 vals)) nil + (cdr + (nth 1 vals)))) + ) + (DEFINE-MODULE + name-args + ,(semantic-lambda + (semantic-tag-new-package + (nth + (length + (nth 1 vals)) + (nth 1 vals)) nil)) + ) + (LOAD + string + ,(semantic-lambda + (semantic-tag-new-include + (file-name-nondirectory + (read + (nth 1 vals))) + (read + (nth 1 vals)))) + ) + (symbol + ,(semantic-lambda + (semantic-tag-new-code + (nth 0 vals) nil)) + ) + ) ;; end scheme-in-list + + (name-args + (semantic-list + ,(lambda (vals start end) + (semantic-bovinate-from-nonterminal + (car + (nth 0 vals)) + (cdr + (nth 0 vals)) + 'name-arg-expand)) + ) + ) ;; end name-args + + (name-arg-expand + (open-paren + name-arg-expand + ,(semantic-lambda + (nth 1 vals)) + ) + (symbol + name-arg-expand + ,(semantic-lambda + (cons + (nth 0 vals) + (nth 1 vals))) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end name-arg-expand + + (opt-doc + (string) + ( ;;EMPTY + ) + ) ;; end opt-doc + + (sequence + (expression + sequence) + (expression) + ) ;; end sequence + + (expression + (symbol) + (semantic-list) + (string) + (number) + ) ;; end expression + ) + "Parser table.") + +(defun semantic-scm-by--install-parser () + "Setup the Semantic Parser." + (setq semantic--parse-table semantic-scm-by--parse-table + semantic-debug-parser-source "scheme.by" + semantic-debug-parser-class 'semantic-bovine-debug-parser + semantic-flex-keywords-obarray semantic-scm-by--keyword-table + )) + + +;;; Analyzers +;; +(require 'semantic/lex) + + +;;; Epilogue +;; + +(provide 'semantic/bovine/scm-by) + +;;; semantic/bovine/scm-by.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/bovine/scm.el Sat Sep 05 20:47:41 2009 +0000 @@ -0,0 +1,116 @@ +;;; semantic/bovine/scm.el --- Semantic details for Scheme (guile) + +;;; Copyright (C) 2001, 2002, 2003, 2004, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Use the Semantic Bovinator for Scheme (guile) + +(require 'semantic) +(require 'semantic/bovine/scm-by) +(require 'semantic/format) + +(eval-when-compile + (require 'semantic/dep)) + +;;; Code: + +(defcustom-mode-local-semantic-dependency-system-include-path + scheme-mode semantic-default-scheme-path + '("/usr/share/guile/") + "Default set of include paths for scheme (guile) code. +This should probably do some sort of search to see what is +actually on the local machine.") + +(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))))) + +;; Note: Analyzer from Henry S. Thompson +(define-lex-regex-analyzer semantic-lex-scheme-symbol + "Detect and create symbol and keyword tokens." + "\\(\\sw\\([:]\\|\\sw\\|\\s_\\)+\\)" + ;; (message (format "symbol: %s" (match-string 0))) + (semantic-lex-push-token + (semantic-lex-token + (or (semantic-lex-keyword-p (match-string 0)) 'symbol) + (match-beginning 0) (match-end 0)))) + + +(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-scheme-symbol + semantic-lex-charquote + semantic-lex-paren-or-list + semantic-lex-close-paren + semantic-lex-string + semantic-lex-ignore-comments + semantic-lex-punctuation + semantic-lex-number + semantic-lex-default-action) + +(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 + imenu-create-index-function 'semantic-create-imenu-index + ) + (setq semantic-lex-analyzer #'semantic-scheme-lexer) + ) + +(add-hook 'scheme-mode-hook 'semantic-default-scheme-setup) + +(provide 'semantic/bovine/scm) + +;;; semantic/bovine/scm.el ends here