--- /dev/null
+;;; 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)
+ ))
+
+\f
+;;; Analyzers
+;;
+(require 'semantic/lex)
+
+\f
+;;; Epilogue
+;;
+
+(provide 'semantic/bovine/c-by)
+
+;;; semantic/bovine/c-by.el ends here
--- /dev/null
+;;; 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'.")
+
+\f
+;;; 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)
+
+\f
+;;; 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)
+
+\f
+;;; 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
+;;; 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
+;;; 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:
+\f
+;;; 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)
+\f
+;;; 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)
+ ))))
+\f
+;;; 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
+ )
+\f
+;;; 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
+;;; 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
+;;; 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))
+
+\f
+;;; 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]
+ ;")
+\f
+;;; 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))
+\f
+;;; 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)))))
+ ))))
+\f
+;;; 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)))
+
+\f
+;;; 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
+;;; 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))
+\f
+;;; Prologue
+;;
+\f
+;;; 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
+ ))
+
+\f
+;;; Analyzers
+;;
+(require 'semantic/lex)
+
+\f
+;;; Epilogue
+;;
+
+(provide 'semantic/bovine/make-by)
+
+;;; semantic/bovine/make-by.el ends here
--- /dev/null
+;;; 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
+;;; 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))
+\f
+;;; Prologue
+;;
+\f
+;;; 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
+ ))
+
+\f
+;;; Analyzers
+;;
+(require 'semantic/lex)
+
+\f
+;;; Epilogue
+;;
+
+(provide 'semantic/bovine/scm-by)
+
+;;; semantic/bovine/scm-by.el ends here
--- /dev/null
+;;; 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
projects / emacs.git / commitdiff